#lang racket

; By Jacob J. A. Koot.

(provide fmt fmt? fmtp?)

;===============================================================================
; Section 1
; Format procedures.
; Every format procedure is a structure with procedure property.
; Procedure   : fmt-proc   : For prop:procedure. Not provided.
; Constructor : make-fmt   : Raw constructor, not provided.
; Constructor : fmt        : Provided. Calls make-fmt after checking arguments.
; Predicate   : fmt?       : Provided.
; Accessor    : fmt-instrs : List of instructions (procedures), not provided.
; Accessor    : fmt-port   : Destination output-port, not provided.

;-------------------------------------------------------------------------------
; Section 1a
; Constructor fmt.

(define (fmt . args)
 (let-values (((fmt-str port fmts) (check-and-rearrange-args-of-fmt args)))
  (make-fmt (fmt-parser fmt-str fmts) port)))

(define (check-and-rearrange-args-of-fmt args)
 (let loop ((args args) (fmt-str "") (separator "") (port #f) (fmts '()))
  ; args      : args of procedure fmt.
  ; fmt-str   : concatenation of the fmt-strings encountered in args.
  ; separator : separator to be put between fmt-strings encountered in args.
  ; port      : output-port found among the args.
  ; fmts      : list of fmt-procs encountered among the args.
  ; Check that fmt-string args do not contain backslashes outside literals.
  ; Insert backslashes in formed fmt-str where fmt-procs are to be called.
  ; Check that literals are not split over two or more args.
  ; Check that quotes are balanced.
  (if (null? args) (values fmt-str (or port 'string) (reverse fmts))
   (let ((arg (car args)) (args (cdr args)))
    (cond
     ((fmtstr? arg) ; concatenate partial fmt-strings.
      (loop args (string-append fmt-str separator arg) "," port fmts))
     ((fmt? arg) ; Insert a backslash where an fmt-proc is to be called.
      (loop args (string-append fmt-str "\\") separator port (cons arg fmts)))
     ((or (memq arg '(string current argument str arg cur)) (output-port? arg))
      ; Handle port argument.
      (if port (error 'fmt "multiple port argument: ~s" arg)
       (loop args fmt-str separator arg fmts)))
     (else (raise-type-error 'fmt "fmt-string, fmt-proc or port" arg)))))))

; Predicate (fmtstr? arg) -> #t if arg is (partial) fmt-str, else #f.
; Check that the string does not contain backslashes outside literals.
; Check that quotes are balanced.
; Finite automaton.
; state 0 = outside literal
; state 1 = inside literal
; state 2 = end of literal or first of two adjacent single quotes in literal.
; Check termination in state 0 or 2.

(define (fmtstr? arg)
 (and (string? arg)
  (let loop ((chars (string->list arg)) (state 0))
   (or
    (and
     (null? chars)
     (when (= state 1) (unbalanced-quote-error arg)))
    (case state
     ((0) ; outside literal
      (case (car chars)
       ((#\\) (slash-error arg)) ; prohibit backslash
       ((#\') (loop (cdr chars) 1)) ; enter state 1 after starting quote
       (else (loop (cdr chars) 0))))
     ((1) ; inside literal
      (if (char=? (car chars) #\')
       (loop (cdr chars) 2) ; quote: terminator or double-quote?
       (loop (cdr chars) 1))) ; continue inside literal
     ((2) ; after terminating quote or first of double quote
      (case (car chars)
       ((#\') (loop (cdr chars) 1)) ; 2 adjacent single quotes within literal.
       ((#\\) (slash-error arg)) ; prohibit backslash outside literal.
       (else (loop (cdr chars) 0))))))))) ; continue outside literal

(define (unbalanced-quote-error arg) (error 'fmt "unbalanced quote in ~s" arg))
(define (slash-error arg) (error 'fmt "\\ is not an fmt instr in: ~s" arg))

;-------------------------------------------------------------------------------
; Section 1b
; The format procecure proper for the procedure property of the underlying fmt
; struct type. Notice that procedure fmt-proc must be defined before the struct
; type can be defined in section 1c.

(define (fmt-proc fmt-struct . user-data)
 (let*-values
  (((port user-data)
    (check-and-extract-args-of-fmt-proc (fmt-port fmt-struct) user-data))
   ; Initialize the run time state.
   ((run-state) (make-new-run-time-state user-data)))
  (let ((port (if (memq port '(cur current)) (current-output-port) port)))
   (when (output-port? port)
    (when (port-closed? port)
     (error 'fmt "port ~a is closed" port))))
  ; Run the format instructions.
  ; Call-with-exit will store the top level exit.
  ; Run-instrs will store the local exit.
  (call-with-exit run-state run-state-top-exit set-run-state-top-exit!
   (λ () (run-instrs run-state (fmt-instrs fmt-struct))))
  ; Check that all data have been consumed.
  (let ((remaining-data (run-state-data run-state)))
   (when (not (null? remaining-data))
    (run-error 1 remaining-data)))
  ; Return results as string or send them to output-port.
  (let ((result (get-output-string (run-state-temp-port run-state))))
   (case port
    ((string str) result)
    ((current cur) (display result))
    (else (display result port))))))

(define (check-and-extract-args-of-fmt-proc port user-data)
 (cond ; checks the args of fmt-proc.
  ((not (memq port '(argument arg))) (values port user-data))
  ((pair? user-data)
   (let ((port (car user-data)) (user-data (cdr user-data)))
    (unless (or (output-port? port) (memq port '(string current str cur)))
     (raise-type-error 'fmt-proc port-type-string port))
    (values port user-data)))
  (else (raise-type-error 'fmt-proc port-type-string 'none))))

(define port-type-string "output-port or symbol current or string")

;-------------------------------------------------------------------------------
; Section 1c
; Underlying struct type for fmt-procs.

(define sibling-inspector (make-sibling-inspector))
(define (fmt-printer fmt-struct port write?) (fprintf port "#<fmt>"))

(define-values (fmt-descr make-fmt fmt? fmt-acc fmt-mut)
 (make-struct-type
  'fmt ; name
  #f ; no super struct type
  2 ; nr of fields: list-of-instr-procs and port-argument
  0 ; no auto fields
  #f ; no auto value
  (list (cons prop:custom-write fmt-printer)) ; property list
  sibling-inspector
  fmt-proc ; procedure property
  '(0 1) ; both fields are immutable
  #f)) ; no guard

(define fmt-instrs (make-struct-field-accessor fmt-acc 0))
(define fmt-port (make-struct-field-accessor fmt-acc 1))
(define (fmtp? x) (and (fmt? x) (memq (fmt-port x) '(argument arg)) #t))

;===============================================================================
; Section 2
; Run time engine

;-------------------------------------------------------------------------------
; Section 2a
; Run time engine proper.

(define (run-instrs run-state instrs) ; runs a list of format instructions.
 (call-with-exit run-state run-state-local-exit set-run-state-local-exit!
  (λ ()
   (let loop ((instrs instrs))
    (when (not (null? instrs))
     ((car instrs) run-state)
     (loop (cdr instrs)))))))

;-------------------------------------------------------------------------------
; Section 2b
; Run time state.

(define-struct run-state
 (data local-exit top-exit temp-port tab-offset align fieldwidth sign-mode)
 #:mutable #:omit-define-syntaxes)

(define (make-new-run-time-state user-data)
 (make-run-state
  user-data ; list of remaining data to be formatted.
  #f ; local exit: defined when top level fmt proc or sub-fmt proc is called.
  #f ;   top exit: defined when top level fmt proc is called.
  (open-output-string) ; temporary output-port
  0                    ; initial tab offset.
  no-align             ; initial alignment.
  0                    ; initial fieldwidth.
  ""))                 ; initial sign mode (always either "" or "+")

(define (push-data run-state . new-data)
 (set-run-state-data! run-state (append new-data (run-state-data run-state))))

(define (pop-datum run-state (pred any?) (type-str ""))
 (let ((data (run-state-data run-state)))
  (if (null? data) (run-error 2)
   (let ((datum (car data)))
    (set-run-state-data! run-state (cdr data))
    (if (pred datum) datum (run-error 3 datum type-str))))))

(define (peek-datum run-state (pred any?) (type-str ""))
 (let ((data (run-state-data run-state)))
  (if (null? data) (run-error 2)
   (let ((datum (car data)))
    (if (pred datum) datum
     (run-error 3 datum type-str))))))

(define (call-with-exit run-state accessor mutator thunk)
 (let ((old-exit (accessor run-state)))
  (let/ec new-exit (mutator run-state new-exit) (thunk))
  (mutator run-state old-exit)))

;===============================================================================
; Section 3
; Parser : translates a complete fmt-str into a list of instructions.
; Each instruction is a procedure of one argument, namely the run-state.
; All parsing procedures use the parser-state.

;-------------------------------------------------------------------------------
; Section 3a
; Parsing time state

(define-struct parser-state (str chars fmts) #:mutable #:omit-define-syntaxes)
; str   : The original string is stored for error messages.
; chars : list of characters yet to be parsed.
; fmts  : list of fmt-procedures to be inserted.

(define (push-fmt-chars parser-state . chars)
 (set-parser-state-chars! parser-state
  (append chars (parser-state-chars parser-state))))

(define (peek-fmt-char parser-state)
 (let ((chars (parser-state-chars parser-state)))
  (and (not (null? chars)) (car chars))))

(define (pop-fmt-char parser-state (required #t))
 (let ((chars (parser-state-chars parser-state)))
  (cond
   ((pair? chars)
    (set-parser-state-chars! parser-state (cdr chars))
    (car chars))
   (required (fmt-error parser-state))
   (else #f))))

(define (pop-fmt parser-state)
 (let ((fmts (parser-state-fmts parser-state)))
  (set-parser-state-fmts! parser-state (cdr fmts))
  (car fmts)))

;-------------------------------------------------------------------------------
; Section 3b
; The parser proper.

(define (fmt-parser fmt-str (fmts '())) ; returns a list of procedures
 (parse-fmt-str (make-parser-state fmt-str (string->list fmt-str) fmts)))

(define (parse-fmt-str parser-state) ; Parses the whole fmt-str.
 (let loop ((instrs '()))
  (let ((instr (parse-fmt-instr parser-state)))
   (if instr (loop (cons instr instrs))
    (reverse instrs)))))

(define (parse-fmt-instr parser-state) ; Parses one single instruction.
 (skip-white-fmt-and-commas parser-state)
 (let ((char (pop-fmt-char parser-state #f)))
  (case char
   ((#f) #f) ; signals that no more instructions follow.
   ; Cases that need more parsing call an instruction-parser proc.
   ; Cases that need no more parsing directly return the related instruction.
   ((#\# #\. #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)
    (push-fmt-chars parser-state char)
    (parse-repeat-instr parser-state))
   ((#\\) (include-fmt (pop-fmt parser-state)))
   ((#\!) (parse-if-more-data-instr parser-state))
   ((#\?) (parse-if-no-more-data-instr parser-state))
   ((#\+) set-sign-mode-instr)
   ((#\-) clear-sign-mode-instr)
   ((#\$) (parse-retain-sign-instr parser-state))
   ((#\') (parse-literal-instr parser-state))
   ((#\^) (parse-special-literal-instr parser-state))
   ((#\() (parse-compound-instr parser-state #\)))
   ((#\[) (parse-special-compound-instr parser-state))
   ((#\*) (parse-indefinite-repeat-instr parser-state))
   ((#\/) newline-instr)
   ((#\|) newline-but-not-double)
   ((#\:) local-exit-instr)
   ((#\;) top-exit-instr)
   ((#\@elem["@"]) (parse-retain-tab-offset-instr parser-state))
   ((#\&) eol-tab-instr)
   ((#\>) (parse-rel-forward-tab-instr parser-state))
   ((#\<) (parse-rel-backward-tab-instr parser-state))
   ((#\~) remaining-data-instr)
   ((#\=) read-instr)
   ((#\λ) call-proc-instr)
   ((#\%) numerator/denominator-instr)
   ((#\A #\a) (parse-retain-align-instr parser-state))
   ((#\B #\b) binary-num-instr)
   ((#\C #\c) (parse-align-instr parser-state centre-align))
   ((#\D #\d) display-instr)
   ((#\E #\e) (parse-e-fmt-instr parser-state))
   ((#\F #\f) (parse-float-instr parser-state))
   ((#\G #\g) date-instr)
   ((#\H #\h) hex-num-instr)
   ((#\I #\i) (parse-int-instr parser-state))
   ((#\J #\j) read-all-instr)
   ((#\K #\k) call-fmt-instr)
   ((#\L #\l) (parse-align-instr parser-state left-align))
   ((#\M #\m) (parse-retain-state-instr parser-state))
   ((#\N #\n) no-alignment-instr)
   ((#\O #\o) octal-num-instr)
   ((#\P #\p) print-instr)
   ((#\Q #\q) (parse-if-datum-instr parser-state))
   ((#\R #\r) (parse-align-instr parser-state right-align))
   ((#\S #\s) skip-instr)
   ((#\T #\t) (parse-tab-instr parser-state))
   ((#\U #\u) unfold-instr)
   ((#\V #\v) recursive-unfold-instr)
   ((#\W #\w) write-instr)
   ((#\X #\x) space-instr)
   ((#\Y #\y) unfold-complex-instr)
   ((#\Z #\z) unfold-all-instr)
   (else (fmt-error parser-state)))))

;------------------------------------------------------------------------------
; Section 3c
; Alignment instruction parser (instructions L, R and C)

(define (parse-align-instr parser-state aligner)
 (let ((numeric-arg-proc (parse-numeric-arg parser-state)))
  (λ (run-state)
   (set-run-state-align! run-state aligner)
   (set-run-state-fieldwidth! run-state (numeric-arg-proc run-state)))))

;------------------------------------------------------------------------------
; Section 3d
; Numerical format instruction parsers (instruction I, F and E)

(define-syntax def-num-fmt-instr
 (syntax-rules ()
  ((_ name instr m n ...)
   (define (name parser-state)
    (let
     ((m (parse-numeric-arg parser-state))
      (n (parse-numeric-arg parser-state)) ...)
     (λ (run-state)
      (let
       ((m (m run-state))
        (n (n run-state)) ...
        (datum (pop-datum run-state real? "real")))
       (display
        (pad-left
         (check-inf/nan datum (λ () (instr run-state datum n ...)))
         m)
        (run-state-temp-port run-state)))))))))

(def-num-fmt-instr parse-int-instr   fmt-int  m n)
(def-num-fmt-instr parse-float-instr fmt-real m n)
(def-num-fmt-instr parse-e-fmt-instr fmt-e    m n k)

;------------------------------------------------------------------------------
; Section 3e
; Conditional instruction parsers (instructions !, ? and Q)

(define (parse-if-more-data-instr parser-state)
 (let ((instr (parse-fmt-instr parser-state)))
  (when (not instr) (fmt-error parser-state))
  (λ (run-state)
   (when (not (null? (run-state-data run-state))) (instr run-state)))))

(define (parse-if-no-more-data-instr parser-state)
 (let ((instr (parse-fmt-instr parser-state)))
  (when (not instr) (fmt-error parser-state))
  (λ (run-state)
   (when (null? (run-state-data run-state)) (instr run-state)))))

(define (parse-if-datum-instr parser-state)
 (let ((then (parse-fmt-instr parser-state))
       (else (parse-fmt-instr parser-state)))
  (when (not else) (fmt-error parser-state))
  (λ (run-state)
   (if (peek-datum run-state)
    (then run-state)
    (else run-state)))))

;------------------------------------------------------------------------------
; Section 3f
; Iteration instruction parsers (instructions *, # and number)

(define (parse-indefinite-repeat-instr parser-state)
 (let ((instr (parse-fmt-instr parser-state)))
  (when (not instr) (fmt-error parser-state))
  (λ (run-state)
   (let loop ()
    (when (not (null? (run-state-data run-state)))
     (instr run-state)
     (loop))))))

(define (parse-repeat-instr parser-state)
 (let
  ((get-n (parse-numeric-arg parser-state))
   (instr (parse-fmt-instr parser-state)))
  (when (not instr) (fmt-error parser-state))
  (λ (run-state)
   (let loop ((n (get-n run-state)))
    (when (> n 0)
     (instr run-state)
     (loop (sub1 n)))))))

;------------------------------------------------------------------------------
; Section 3g
; Tabulation instruction parsers (instructions T, > and <)

(define (parse-tab-instr parser-state)
 (let ((n (parse-numeric-arg parser-state)))
  (λ (run-state)
   (let ((p (run-state-temp-port run-state)))
    (let*
     ((current-length (string-length (get-output-string p)))
      (new-pos (+ (run-state-tab-offset run-state) (n run-state))))
     (cond
      ((> new-pos current-length)
       (file-position p current-length)
       (display (make-string (- new-pos current-length) #\space) p))
      (else (file-position p new-pos))))))))

(define (parse-rel-forward-tab-instr parser-state)
 (parse-rel-tab-instr parser-state +))

(define (parse-rel-backward-tab-instr parser-state)
 (parse-rel-tab-instr parser-state -))

(define (parse-rel-tab-instr parser-state sense)
 (let ((n (parse-numeric-arg parser-state)))
  (λ (run-state)
   (let*
    ((p (run-state-temp-port run-state))
     (n (sense (file-position p) (n run-state))))
    (if (< n (run-state-tab-offset run-state)) (run-error 4 n)
     (let ((len (string-length (get-output-string p))))
      (cond
       ((<= n len)
        (file-position p n))
       (else
        (file-position p len)
        (display (make-string (- n len) #\space) p)))))))))

;------------------------------------------------------------------------------
; Section 3h
; Retain state instruction parsers (instruction A, $, @elem["@"] and M)

(define-syntax define-parse-retain-instr
 (syntax-rules ()
  ((_ name field ...)
   (define (name parser-state)
    (let ((instr (parse-fmt-instr parser-state)))
     (when (not instr) (fmt-error parser-state))
     (λ (run-state)
      (let ((field (get-field field run-state)) ...)
       (instr run-state)
       (reset-field field run-state) ...)))))))

(define-syntax (get-field stx)
 (syntax-case stx ()
  ((_ field run-state)
 #`(#,(datum->syntax
  #'here
    (string->symbol
     (string-append "run-state-"
      (symbol->string (syntax->datum #'field)))))
    run-state))))

(define-syntax (reset-field stx)
 (syntax-case stx ()
  ((_ field run-state)
 #`(#,(datum->syntax
   #'here
     (string->symbol
      (string-append "set-run-state-"
       (symbol->string (syntax->datum #'field))
       "!")))
    run-state field))))

(define-parse-retain-instr parse-retain-align-instr align fieldwidth)
(define-parse-retain-instr parse-retain-sign-instr sign-mode)
(define-parse-retain-instr parse-retain-tab-offset-instr tab-offset)

(define-parse-retain-instr
 parse-retain-state-instr tab-offset sign-mode align fieldwidth)

;------------------------------------------------------------------------------
; Section 3i
; Literal instructions.

(define (parse-literal-string parser-state)
 (let loop ((chars '()))
  (let ((char (pop-fmt-char parser-state)))
   (if (not (char=? char #\')) (loop (cons char chars))
    (let ((peek (peek-fmt-char parser-state)))
     (if (and peek (char=? peek #\'))
      (loop (cons (pop-fmt-char parser-state) chars))
      (apply string (reverse chars))))))))

(define (parse-literal-instr parser-state)
 (let ((str (parse-literal-string parser-state)))
  (λ (run-state)
   (push-data run-state str)
   (display-instr run-state))))

(define (parse-special-literal-instr parser-state)
 (skip-white-fmt-and-commas parser-state)
 (unless (char=? (pop-fmt-char parser-state) #\') (fmt-error parser-state))
 (let ((p (open-input-string (parse-literal-string parser-state))))
  (let loop ((data '()))
   (let ((datum (literal-reader p)))
    (if (eof-object? datum)
     (let ((data (reverse data)))
      (λ (run-state) (apply push-data run-state data)))
     (loop (cons datum data)))))))

(define (literal-reader p)
 (parameterize ((uncaught-exception-handler literal-read-exn))
  (read p)))

(define (literal-read-exn-fmt msg)
 (format "fmt, incorrect datum in ^ instruction: ~s" msg))

(define (literal-read-exn exn)
 ((error-display-handler) (literal-read-exn-fmt (exn-message exn)) exn)
 ((error-escape-handler)))

;------------------------------------------------------------------------------
; Section 3j
; Compound instructions.

(define (parse-compound-instr parser-state terminator)
 (let loop ((instrs '()))
  (skip-white-fmt-and-commas parser-state)
  (let ((char (pop-fmt-char parser-state)))
   (cond
    ((char=? char terminator)
     (let ((instrs (reverse instrs)))
      (λ (run-state) (run-instrs run-state instrs))))
    ((char=? char #\,) (loop instrs))
    (else
     (push-fmt-chars parser-state char)
     (loop (cons (parse-fmt-instr parser-state) instrs)))))))

(define (parse-special-compound-instr parser-state)
 (let ((instr (parse-compound-instr parser-state #\])))
  (λ (run-state)
   (let
    ((temp-port (run-state-temp-port run-state))
     (tab-offset (run-state-tab-offset run-state)))
    (set-run-state-temp-port! run-state (open-output-string))
    (set-run-state-tab-offset! run-state 0)
    (instr run-state)
    (push-data run-state (get-output-string (run-state-temp-port run-state)))
    (set-run-state-temp-port! run-state temp-port)
    (set-run-state-tab-offset! run-state tab-offset)))))

;------------------------------------------------------------------------------
; Section 3k
; Parser for numerical argument.

(define (parse-numeric-arg parser-state)
 (skip-white-fmt parser-state)
 (let ((char (peek-fmt-char parser-state)))
  (cond
   ((not char) (λ (run-state) 0))
   ((char=? char #\#)
    (pop-fmt-char parser-state)
    (λ (run-state)
     (pop-datum run-state exact-nonnegative-integer? "natural number")))
   (else
    (let loop ((n 0) (char char))
     (cond
      ((not char) (λ (run-state) n))
      ((char=? char #\.) (pop-fmt-char parser-state) (λ (run-state) n))
      ((char-numeric? char)
       (pop-fmt-char parser-state)
       (loop
        (+ (* 10 n) (string->number (string char)))
        (peek-fmt-char parser-state)))
      (else (λ (run-state) n))))))))

;------------------------------------------------------------------------------
; Section 3l
; Auxiliary procs for parser

(define (fmt-error parser-state)
 (let
  ((chars (parser-state-chars parser-state))
   (str (parser-state-str parser-state)))
  (error 'fmt "incorrect format instruction at position ~s in format ~s"
   (- (string-length str) (length chars) 1) str)))

(define (skip-white-fmt parser-state)
 (let loop ((chars (parser-state-chars parser-state)))
  (if (and (not (null? chars)) (char-whitespace? (car chars)))
   (loop (cdr chars))
   (set-parser-state-chars! parser-state chars))))

(define (skip-white-fmt-and-commas parser-state)
 (let loop ((chars (parser-state-chars parser-state)))
  (if
   (and
    (not (null? chars))
    (let ((char (car chars)))
     (or (char=? char #\,) (char-whitespace? char))))
   (loop (cdr chars))
   (set-parser-state-chars! parser-state chars))))

;------------------------------------------------------------------------------
; Section 3m
; Include fmt

(define (include-fmt fmt)
 (λ (run-state) (run-instrs run-state (fmt-instrs fmt))))

;===============================================================================
; Section 4
; Instructions that do not need further parsing.
;-------------------------------------------------------------------------------
; Section 4a
; Display/write/print instructions (D, W and P)

(define (display-instr run-state)
 (when (not (eq? (run-state-align run-state) no-align))
  (let ((datum (pop-datum run-state)))
   (push-data run-state
    (if (string? datum)
     (strip-head-and-trail-spaces datum)
     datum))))
 (printer run-state display))

(define (write-instr run-state) (printer run-state write)) ; Instruction W.
(define (print-instr run-state) (printer run-state print)) ; Instruction P.

(define (printer run-state instr)
 (let ((datum (pop-datum run-state)) (out-str (open-output-string)))
  (instr datum out-str)
  (display
   ((run-state-align run-state)
    (get-output-string out-str)
    (run-state-fieldwidth run-state))
   (run-state-temp-port run-state))))

(define (strip-head-and-trail-spaces str)
 (let ((len (string-length str)))
  (let head-loop ((n 0))
   (cond
    ((>= n len) "")
    ((char=? (string-ref str n) #\space) (head-loop (add1 n)))
    (else
     (let tail-loop ((m len))
      (let ((m-1 (sub1 m)))
       (if (char=? (string-ref str m-1) #\space) (tail-loop m-1)
        (if (and (= n 0) (= m len)) str (substring str n m))))))))))

;-------------------------------------------------------------------------------
; Section 4b
; No alignment instruction N.

(define (no-alignment-instr run-state)
 (set-run-state-align! run-state no-align)
 (set-run-state-fieldwidth! run-state 0))

;-------------------------------------------------------------------------------
; Section 4c
; Numerical formats (instructions B, O, H)

(define (binary-num-instr run-state) (num-instr-with-base run-state  2))
(define ( octal-num-instr run-state) (num-instr-with-base run-state  8))
(define (   hex-num-instr run-state) (num-instr-with-base run-state 16))

;-------------------------------------------------------------------------------
; Section 4d
; Tabulation instruction &.

(define (eol-tab-instr run-state)
 (let ((p (run-state-temp-port run-state)))
  (file-position p (string-length (get-output-string p)))))

;------------------------------------------------------------------------------
; Section 4e
; Unfolders (instructions U, V, Y and Z)

(define (unfold-instr run-state)
 (let ((datum (pop-datum run-state)))
  (cond
   ((list? datum)
    (apply push-data run-state (length datum) datum))
   ((vector? datum)
    (apply push-data run-state (vector-length datum) (vector->list datum)))
   ((struct? datum)
    (let* ((vec (struct->vector datum)) (len (vector-length vec)))
     (apply push-data run-state len (vector->list vec))))
   (else (push-data run-state 1 datum)))))

(define (recursive-unfold-instr run-state)
 (let ((data (recursively-unfold (pop-datum run-state))))
  (apply push-data run-state (length data) data)))

(define (unfold-all-instr run-state)
 (let ((new-data (recursively-unfold (run-state-data run-state))))
  (set-run-state-data! run-state (cons (length new-data) new-data))))

(define (unfold-complex-instr run-state)
 (let ((datum (pop-datum run-state number? "number")))
  (push-data run-state (real-part datum) (imag-part datum))))

(define (recursively-unfold data) ; For vectors and structs not protected
 (cond                            ; against circularity.
  ((list? data) (apply append (map recursively-unfold data)))
  ((vector? data) (recursively-unfold (vector->list data)))
  ((struct? data) (recursively-unfold (vector->list (struct->vector data))))
  (else (list data))))

;-------------------------------------------------------------------------------
; Section 4f
; Miscelaneous instructions (X, :, ;, S, +, -, /, |)

(define (space-instr run-state) (display " " (run-state-temp-port run-state)))
(define (local-exit-instr run-state) ((run-state-local-exit run-state) (void)))
(define (top-exit-instr run-state) ((run-state-top-exit run-state) (void)))
(define (skip-instr run-state) (void (pop-datum run-state)))

(define (clear-sign-mode-instr run-state)
 (set-run-state-sign-mode! run-state ""))

(define (set-sign-mode-instr run-state)
 (set-run-state-sign-mode! run-state "+"))

(define (newline-instr run-state)
 (let ((p (run-state-temp-port run-state)))
  (newline p)
  (set-run-state-tab-offset! run-state (file-position p))))

(define (newline-but-not-double run-state)
 (unless
  (=
   (file-position (run-state-temp-port run-state))
   (run-state-tab-offset run-state))
  (newline-instr run-state)))

;-------------------------------------------------------------------------------
; Section 4g
; Date/time instruction (G)

(define (date-instr run-state)
 (let*-values
  (((week-day day month year hour minute second time-zone)
    (apply values (date-time-components run-state)))
   ((week-day) (vector-ref week-days week-day))
   ((month) (vector-ref months month))
   ((tzh tzm) (quotient/remainder (round (/ time-zone 60)) 60))
   ((tzm) (abs tzm)))
  (push-data run-state week-day day month year hour minute second tzh tzm)
  (date-instr-fmt run-state)))

(define date-time-components
 (let*
  ((selectors
    (list
     date-week-day
     date-day
     date-month
     date-year
     date-hour
     date-minute
     date-second
     date-time-zone-offset)))
  (λ (run-state)
   (let*
    ((datum
      (pop-datum run-state natural-or-false? "natural number or false"))
     (date/time (seconds->date (or datum (current-seconds)))))
    (map (λ (selector) (selector date/time)) selectors)))))

(define week-days #(Sun Mon Tue Wed Thu Fri Sat))
(define months #(#f Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec))

;-------------------------------------------------------------------------------
; Section 4h
; Readers

(define (read-instr run-state) ; Instruction =.
 (let ((p (pop-datum run-state input-port? "input port")))
  (let ((datum (reader p)))
   (if (eof-object? datum) (push-data run-state #f)
    (push-data run-state #t datum)))))

(define (read-all-instr run-state) ; Instruction J.
 (let ((p (pop-datum run-state input-port? "input port")))
  (let loop ((n 0) (lst '()))
   (let ((datum (reader p)))
    (if (eof-object? datum) (apply push-data run-state n (reverse lst))
     (loop (add1 n) (cons datum lst)))))))

(define (reader p)
 (parameterize ((uncaught-exception-handler read-exn))
  (read p)))

(define (read-exn-fmt msg)
 (format "fmt: read error in = or J instr. ~a" msg))

(define (read-exn exn)
 ((error-display-handler) (read-exn-fmt (exn-message exn)) exn)
 ((error-escape-handler)))

;-------------------------------------------------------------------------------
; Section 4i
; Instructions K and λ.

(define (call-fmt-instr run-state)
 (let ((datum (pop-datum run-state fmt-or-str? "fmt or fmt-string")))
  (let ((instrs ((if (string? datum) fmt-parser fmt-instrs) datum)))
   (run-instrs run-state instrs))))

(define (call-proc-instr run-state)
 (let ((proc (pop-datum run-state proc-with-arity-1? "proc with arity 1")))
  (let
   ((data
     (call-with-continuation-barrier
      (λ () (proc (run-state-data run-state))))))
   (if (list? data) (set-run-state-data! run-state data)
    (run-error 5 data)))))

; The continuation barrier in call-proc-instr is installed because it makes
; no sense to reenter the fmt-proc later by means of a continuation made by
; the called proc. The state of the fmt-proc may have been mutated.

;------------------------------------------------------------------------------
; Section 4e
; Unfolders (instruction %)

(define (numerator/denominator-instr run-state)
 (let*
  ((datum (pop-datum run-state real? "real"))
   (sign (get-sign run-state datum))
   (datum (inexact->exact datum)))
  (push-data run-state (numerator datum) (denominator datum))))

;===============================================================================
; Section 5
; Auxiliary procedures for numerical formats.

(define (num-instr-with-base run-state base)
 (let*
  ((datum (pop-datum run-state real? "real"))
   (sign (get-sign run-state datum)))
  (display
   ((run-state-align run-state)
    (check-inf/nan
     datum
     (λ ()
      (string-append sign
       (number->string (abs (inexact->exact datum)) base))))
    (run-state-fieldwidth run-state))
   (run-state-temp-port run-state))))

(define (fmt-int run-state datum n)
 (let
  ((sign (get-sign run-state datum))
   (datum (number->string (round (abs (inexact->exact datum))))))
  (string-append sign (pad-left datum n #\0))))

(define (fmt-real run-state datum n)
 (let ((sign (get-sign run-state datum)) (datum (abs datum)))
  (string-append sign (real->decimal-string datum n))))

(define (fmt-e run-state datum n k)
 (let* ((sign (get-sign run-state datum)) (datum (abs (inexact->exact datum))))
  (if (zero? datum) (zero-e-fmt sign n k)
   (let*-values
    (((n+1) (add1 n))
     ((exp) (order-of-magnitude datum))
     ((datum) (* datum (expt 10 (- n exp))))
     ((rounded-datum) (round datum))
     ((rounded-datum exp)
      (if (>= rounded-datum (expt 10 n+1))
       (values (round (* datum 1/10)) (add1 exp))
       (values rounded-datum exp)))
     ((datum) (number->string rounded-datum))
     ((int-part) (substring datum 0 1))
     ((fraction) (substring datum 1 n+1))
     ((exp)
      (let ((sign-mode (run-state-sign-mode run-state)))
       (set-run-state-sign-mode! run-state "+")
       (begin0 (fmt-int run-state exp k)
        (set-run-state-sign-mode! run-state sign-mode)))))
    (string-append sign int-part "." fraction "e" exp)))))

; Auxiliaries for format e-fmt

(define order-of-magnitude
 (let*
  ((exact-log (λ (x) (inexact->exact (log x))))
   (inverse-exact-log10 (/ (exact-log 10))))
  (λ (r)
   (unless (and (rational? r) (positive? r))
    (raise-type-error 'order-of-magnitude
     "positive real number but not ±inf.0 nor ±nan.0" r))
   (let ((q (inexact->exact r)))
    (let
     ((m
       (floor
        (* (- (exact-log (numerator q)) (exact-log (denominator q)))
         inverse-exact-log10))))
     (let ((p (expt 10 m)))
      (if (< q p)
       (let loop ((m (sub1 m)) (p (* p 1/10)))
        (if (< q p) (loop (sub1 m) (* p 1/10)) m))
       (let loop ((m m) (p (* p 10)))
        (if (>= q p) (loop (add1 m) (* p 10)) m)))))))))

(define (zero-e-fmt sign n k)
 (string-append
  sign
  "0."
  (make-string n #\0)
  "e+"
  (make-string (max 1 k) #\0)))

; Other auxiliaries for numeric formats

(define (check-inf/nan datum thunk)
 (cond
  ((eqv? datum +inf.0) "+inf.0")
  ((eqv? datum -inf.0) "-inf.0")
  ((eqv? datum +nan.0) "+nan.0")
  ((eqv? datum -nan.0) "-nan.0")
  (else (thunk))))

(define (get-sign run-state datum)
 (cond
  ((negative? datum) "-")
  ((eqv? datum -0.0) "-")
  (else (run-state-sign-mode run-state))))

;===============================================================================
; Section 6
; Auxiliary procedures for instructions.

(define (natural-or-false? x) (or (not x) (exact-nonnegative-integer?  x)))
(define (fmt-or-str? x) (or (fmtstr? x) (fmt? x)))
(define (any? x) #t)

(define (proc-with-arity-1? p)
 (and (procedure? p) (procedure-arity-includes? p 1)))

(define (pad-left str m (char #\space))
 (string-append (make-string (max 0 (- m (string-length str))) char) str))

(define (pad-right str m (char #\space))
 (string-append str (make-string (max 0 (- m (string-length str))) char)))

(define (no-align str n) str)
(define (left-align str n) (pad-right str n))
(define (right-align str n) (pad-left str n))

(define (centre-align str n)
 (let ((n (/ (max 0 (- n (string-length str))) 2)))
  (string-append
   (make-string (ceiling n) #\space)
   str
   (make-string (floor n) #\space))))

(define run-error
 (let ((err (λ x (apply error 'fmt x))))
  (λ (n . args)
   (case n
    ((1) (err "the following data are left over at end of fmt: ~s" (car args)))
    ((2) (err "more data expected than actually given"))
    ((3) (raise-type-error 'fmt (cadr args) (car args)))
    ((4) (err "tab instr < results in negative position: ~s" (car args)))
    ((5) (err "λ instr did not return a list. got: ~s" (car args)))
    (else (error 'fmt "system error: proc run-error lacks a case."))))))

;===============================================================================
; Section 7
; The following two procedures come last, because their definition calls
; procedure fmt->instrs and therefore requires almost all stuff already to be
; defined and assigned!

(define remaining-data-instr ; instr ~
 (let ((instrs (fmt-parser "!(&n*(w!x)/)")))
  (λ (run-state) (run-instrs run-state instrs))))

(define date-instr-fmt ; instr G
 (let
  ((instrs
    (fmt-parser "M(N-D','XI2.2XDXI4.4XI2.2':'I2.2':'I2.2X+I2.2-I2.2)")))
  (λ (run-state) (run-instrs run-state instrs))))

;===============================================================================
; The end