#lang scheme
(provide fmt fmt?)
(define (fmt . args)
(let-values (((fmt-str port) (check-and-rearrange-args-of-fmt args)))
(fmt-constr (fmt->instrs fmt-str) port)))
(define (check-and-rearrange-args-of-fmt args)
(let loop ((args args) (format "") (separator "") (port #f))
(if (null? args) (values format (or port 'string))
(let ((arg (car args)) (args (cdr args)))
(cond
((string? arg)
(loop args (string-append format separator arg) "," port))
((or (memq arg '(string current argument str arg cur)) (output-port? arg))
(if port (error 'fmt "multiple port option: ~s" arg)
(loop args format separator arg)))
(else
(raise-type-error 'fmt "string or port" arg)))))))
(define (fmt-proc fmt-struct . args)
(let*-values
(((port user-data)
(check-and-extract-args-of-fmt-proc (fmt-port fmt-struct) args))
((run-state) (make-new-run-time-state user-data)))
(call-with-exit run-state run-state-top-exit set-run-state-top-exit!
(λ () (run-instrs run-state (fmt-instrs fmt-struct))))
(let ((remaining-data (run-state-data run-state)))
(when (not (null? remaining-data))
(run-error 1 remaining-data)))
(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 ((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")
(define inspector (make-sibling-inspector))
(define-values (fmt-descr fmt-constr fmt? fmt-acc fmt-mut)
(make-struct-type 'fmt #f 2 0 #f '() inspector fmt-proc '(0 1) #f))
(define fmt-instrs (make-struct-field-accessor fmt-acc 0))
(define fmt-port (make-struct-field-accessor fmt-acc 1))
(define (run-instrs run-state instrs) (call-with-exit run-state run-state-local-exit set-run-state-local-exit!
(λ ()
(let run-instrs ((instrs instrs))
(when (not (null? instrs))
((car instrs) run-state)
(run-instrs (cdr instrs)))))))
(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 #f #f (open-output-string) 0 no-align 0 ""))
(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 acc mut thunk)
(let ((old-exit (acc run-state)))
(let/ec new-exit (mut run-state new-exit) (thunk))
(mut run-state old-exit)))
(define-struct parser-state (str chars) #:mutable #:omit-define-syntaxes)
(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 (fmt->instrs fmt-str)
(parse-fmt (make-parser-state fmt-str (string->list fmt-str))))
(define (parse-fmt parser-state) (let loop ((instrs '()))
(let ((instr (parse-fmt-instr parser-state)))
(if instr (loop (cons instr instrs))
(reverse instrs)))))
(define (parse-fmt-instr parser-state) (skip-white-fmt parser-state)
(let ((char (pop-fmt-char parser-state #f)))
(case char
((#f) #f) ((#\# #\. #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)
(push-fmt-chars parser-state char)
(parse-repeat-instr parser-state))
((#\, #\space) (parse-fmt-instr 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)
((#\@) (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)
((#\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)))))
(define (parse-align-instr parser-state aligner)
(let ((numeric-arg-proc (parse-numeric-arg-proc parser-state)))
(λ (run-state)
(set-run-state-align! run-state aligner)
(set-run-state-fieldwidth! run-state (numeric-arg-proc run-state)))))
(define-syntax def-num-fmt-instr
(syntax-rules ()
((_ name instr m n ...)
(define (name parser-state)
(let
((m (parse-numeric-arg-proc parser-state))
(n (parse-numeric-arg-proc 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)
(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)))))
(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
((n (parse-numeric-arg-proc parser-state))
(instr (parse-fmt-instr parser-state)))
(when (not instr) (fmt-error parser-state))
(λ (run-state)
(let loop ((n (n run-state)))
(when (> n 0)
(instr run-state)
(loop (sub1 n)))))))
(define (parse-tab-instr parser-state)
(let ((n (parse-numeric-arg-proc 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-proc 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)))))))))
(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)
(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 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)))
(define (parse-compound-instr parser-state terminator)
(let loop ((instrs '()))
(skip-white-fmt parser-state)
(let ((char (pop-fmt-char parser-state)))
(cond
((char=? char terminator)
(let ((instrs (reverse instrs)))
(λ (run-state) (run-instrs run-state 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)))))
(define (parse-numeric-arg-proc 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))))))))
(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 (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)) (define (print-instr run-state) (printer run-state print))
(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))))))))))
(define (no-alignment-instr run-state)
(set-run-state-align! run-state no-align)
(set-run-state-fieldwidth! run-state 0))
(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))
(define (eol-tab-instr run-state)
(let ((p (run-state-temp-port run-state)))
(file-position p (string-length (get-output-string p)))))
(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)
(cond
((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))))
(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)))
(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))
(define (read-instr run-state) (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) (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)))
(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->instrs 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)))))
(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
(((exp) (10log datum))
((datum) (* datum (expt 10 (- exp))))
((datum exp) (normalize-e datum exp))
((factor) (expt 10 n))
((datum) (round (* datum factor)))
((datum exp) (normalize-e-again datum exp factor))
((datum) (number->string datum))
((n+1) (add1 n))
((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)))))
(define (zero-e-fmt sign n k)
(string-append sign "0." (make-string n #\0) "e+" (make-string (max 1 k) #\0)))
(define (normalize-e datum exp)
(cond
((< datum 1) (normalize-e (* datum 10) (sub1 exp)))
((>= datum 10) (normalize-e (/ datum 10) (add1 exp)))
(else (values datum exp))))
(define (normalize-e-again datum exp factor)
(let ((factor*10 (* factor 10)))
(let loop ((datum datum) (exp exp))
(cond
((>= datum factor*10) (loop (round (/ datum 10)) (add1 exp)))
((< datum factor) (loop (* datum 10) (sub1 exp)))
(else (values datum exp))))))
(define 10log
(let ((log10 (log 10)))
(λ (x)
(inexact->exact
(round (/ (- (log (numerator x)) (log (denominator x))) log10))))))
(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")
(else (thunk))))
(define (get-sign run-state datum)
(cond
((negative? datum) "-")
((eqv? datum -0.0) "-")
(else (run-state-sign-mode run-state))))
(define (natural-or-false? x) (or (not x) (exact-nonnegative-integer? x)))
(define (fmt-or-str? x) (or (string? 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."))))))
(define remaining-data-instr (let ((instrs (fmt->instrs "!(&n*(w!x)/)")))
(λ (run-state) (run-instrs run-state instrs))))
(define date-instr-fmt
(let
((instrs (fmt->instrs "M(N-D','XI2.2XDXI4.4XI2.2':'I2.2':'I2.2X+I2.2-I2.2)")))
(λ (run-state) (run-instrs run-state instrs))))