;; (define %make-accessor %make-unsafe-accessor) (define-structure <*end-of-stream-marker*> ()) (define *end* (new <*end-of-stream-marker*>)) (define-method do-print <*end-of-stream-marker*> () (print "<*end-of-stream-marker*>")) (define-selector $at-end) (define-selector $peek) (define-selector $next) ;;;---------------------------------------------------------------- (define-selector $size) (-add-method $size string-length) (define-selector $at) (-add-method $at string-at) (define-function binary-search (seq obj cmp) (let ((lo 0) (hi (- ($size seq) 1)) (ix ())) (while (and (not ix) (<= lo hi)) (let* ((m (/ (+ lo hi) 2)) (s ($at seq m))) (cond ((cmp obj s) (set hi (- m 1))) ((cmp s obj) (set lo (+ m 1))) (else (set ix m))))) (or ix -1))) ;;;---------------------------------------------------------------- (define-structure (string size position)) (define-function string-stream (string) (let ((self (new ))) (set (-string self) string) (set (-size self) (string-length string)) (set (-position self) 0) self)) (define-method $at-end () (= self.position self.size)) (define-method $peek () (let ((pos self.position)) (if (< pos self.size) (string-at self.string pos) *end*))) (define-method $next () (let ((pos self.position)) (if (< pos self.size) (let ((value (string-at self.string pos))) (set self.position (+ pos 1)) value) *end*))) (unit-test "" (let ((s (string-stream "xhello")) (c 0) (a (array))) (unit-assert (= ?x ($peek s))) (unit-assert (= ?x ($next s))) (unit-assert (= ?h ($peek s))) (while (!= *end* (set c ($next s))) (array-append a c)) (unit-assert (= "hello" (array->string a))) (unit-assert (= *end* ($peek s))) (unit-assert (= *end* ($next s))))) (define-method $source-position ()) (define-method $source-position () (cons "" self.position)) ;;;---------------------------------------------------------------- (define-structure (source)) (define-function list-stream (source) (let ((self (new ))) (set (-source self) source) self)) (define-method $at-end () (not self.source)) (define-method $peek () (if self.source (car self.source) *end*)) (define-method $next () (if self.source (let ((value (car self.source))) (set self.source (cdr self.source)) value) *end*)) (unit-test "" (let ((s (list-stream '(?x ?h ?e (l (l)) () ?o))) (c 0) (a (array))) (unit-assert (= ?x ($peek s))) (unit-assert (= ?x ($next s))) (unit-assert (= ?h ($peek s))) (while (!= *end* (set c ($next s))) (array-append a c)) (unit-assert (equal '(?h ?e (l (l)) () ?o) (array->list a))) (unit-assert (= *end* ($peek s))) (unit-assert (= *end* ($next s))))) (define-method $source-position () ()) ;;;---------------------------------------------------------------- (define-structure (source pending srcpos)) (define-function input-stream (source path) (let ((self (new ))) (set (-source self) source) (set (-srcpos self) (cons path 1)) self)) (define-method $at-end () (= () ($peek self))) (define-method $peek () (or self.pending (if self.source (let ((c (getc self.source))) (if c (let () (and (= ?\n c) (set self.srcpos (cons (car self.srcpos) (+ 1 (cdr self.srcpos))))) (set self.pending c)) (or (= self.source *input*) (close self.source)) (set self.source ()) (set self.pending *end*))) (set self.pending *end*)))) (define-method $next () (let ((c ($peek self))) (set (-pending self) ()) c)) (define-method $source-position () self.srcpos) (define-function input-stream-up-to (self delimiter) (let ((a (array))) (while (!= delimiter ($peek self)) (array-append a ($next self))) (array->string a))) ;; *** moved to boot.l *** ;; (define-function contents-of-file-named (name) ;; (input-stream-up-to (input-stream (or (open name) ;; (error "no such file: "name)) ;; name) *end*)) ;; (unit-test "" ;; (let ((s (input-stream *input*)) ;; (c 0) ;; (a (array))) (unit-assert (= ?; ($peek s))) ;; (unit-assert (= ?; ($next s))) ;; (unit-assert (= ?h ($peek s))) ;; (while (!= ?! (set c ($next s))) ;; (array-append a c)) (unit-assert (= "hello" (array->string a))) ;; (unit-assert (= "goodbye" (input-stream-up-to s ?!)))));hello!goodbye! ;;;---------------------------------------------------------------- ;(define ) (define token cons) (define new- cons) ;(define -value car) (define set--value set-car) ;(define -tail cdr) (define set--tail set-cdr) (define-structure (value tail position notes index)) (define-function new- () (new )) (define-function token (value index srcpos) (let ((self (new ))) (set (-value self) value) (set (-index self) index) (set (-position self) srcpos) self)) (define-method do-print () (print "")) ;(define ) ;(define token cons) ;(define new- cons) ;(define -value car) (define set--value set-car) ;(define -tail cdr) (define set--tail set-cdr) (define-structure (first last)) (define-function group () (let ((self (new )) (token (new-))) (set (-first self) token) (set (-last self) token) self)) (define-function list-from-to (start stop) (and (!= start stop) (cons (-value start) (list-from-to (-tail start) stop)))) (define-function group-from-to (first last) (let ((self (new ))) (set (-first self) first) (set (-last self) last) self)) (define-method do-print () (print "{ ") (let ((pos (-first self)) (lim (-last self))) (while (!= pos lim) (dump (-value pos)) (print " ") (set pos (-tail pos)))) (print "}")) (define-function token-preceeds (a b) (while (and a (!= (-tail a) b)) (set a (-tail a))) a) (define-function group-empty? (self) (= (-first self) (-last self))) (define-function group-length (self) (let ((tok (-first self)) (lim (-last self)) (len 0)) (while (!= tok lim) (set len (+ len 1)) (set tok (-tail tok))) len)) (define-function group-append (self value . stream) (let ((tok (new-)) (last (-last self))) (set (-value last) value) (set (-tail last) tok) (set (-position last) ($source-position (car stream))) (set (-last self) tok))) ;; (define-function group-append-all (self value) ;; (let ((tok (-first value)) ;; (lim (-last value))) ;; (while (!= tok lim) ;; (group-append self (-value tok)) ;; (set tok (-tail tok))))) (define-function group-append-list (self list) (while (pair? list) (group-append self (car list)) (set list (cdr list)))) (define-function group->string (self) (let* ((len (group-length self)) (str (string len)) (idx 0) (tok (-first self))) (while (< idx len) (set (string-at str idx) (-value tok)) (set tok (-tail tok)) (set idx (+ idx 1))) str)) (define-selector group->list (self) self) (define-function set-pair-source-position (obj pos) (set (-source obj) pos) obj) (define-function make-group->list (first last) (and (!= first last) (set-pair-source-position (cons (-value first) ;(group->list (-value first)) (make-group->list (-tail first) last)) (-position first) ))) (define-method group->list () (make-group->list (-first self) (-last self))) (define-function group->list! (self) (group->list self) ;; (let ((start (-first self)) ;; (stop (-last self))) ;; (and (!= start stop) ;; (let ((pos start)) ;; (while (!= (-tail pos) stop) (set pos (-tail pos))) ;; (set (-tail pos) ()) ;; start))) ) ;; (define-function group->list (self) ;; ;;(println "\n\n\n === " self) ;; (let ((first (-first self)) ;; (last (-last self))) ;; (if (= first last) ;; () ;; (while (!= last (cdr first)) ;; ;;(println "\n\n\n" first last) ;; (set first (cdr first)) last) ;; (set-cdr first ()) ;; (-first self)))) (unit-test "" (let ((g (group))) (unit-assert (= 0 (group-length g))) (unit-assert (equal (group->list g) '())) (group-append g 'foo) (unit-assert (= 1 (group-length g))) (unit-assert (equal (group->list g) '(foo))) (group-append g 'bar) (unit-assert (= 2 (group-length g))) (unit-assert (equal (group->list g) '(foo bar))) (group-append-list g '(baz qux)) (unit-assert (= 4 (group-length g))) (unit-assert (equal (group->list g) '(foo bar baz qux))))) ;;;---------------------------------------------------------------- (define-structure (source position index)) ;;(define-function parser-stream (source) ;; (let ((self (new ))) ;; (set (-source self) source) ;; (set (-position self) (new-)) ;; self)) (define-function parser-stream (source) (let ((self (new ))) (set (-source self) source) (set (-position self) (token ($next source) 0 ($source-position (-source self)))) (set (-index self) 0) self)) (define-function parser-stream-at-end (self) (and (= *end* (-value (-position self))))) (define-function parser-stream-peek-token (self) (-position self)) (define-function parser-stream-peek (self) (-value (-position self))) (define-function parser-stream-next-token (self) (let ((here (-position self))) (or (= *end* (-value here)) (let ((tail (-tail here))) (set (-position self) (or tail (set (-tail here) (token ($next (-source self)) (incr (-index self) 1) ($source-position (-source self)) )))))) here)) (define-function parser-stream-next (self) (-value (parser-stream-next-token self))) (define-function parser-stream-push-token (self token) (set (-tail token) (-position self)) (set (-position self) token)) (define-function parser-stream-push (self value) (parser-stream-push-token self (token value (-index self) ($source-position (-source self))))) (define-function parser-stream-match-object (self value) (and (= value (parser-stream-peek self)) (parser-stream-next self))) (define-function parser-stream-match-any (self) (and (!= *end* (parser-stream-peek self)) (parser-stream-next self))) (define-function make-class (s) (let* ((out (array)) (i 0) (l (string-length s)) (k (- l 2))) (while (< i k) (let ((c (string-at s i)) (d (string-at s (+ i 1)))) (if (= ?- d) (let ((e (string-at s (+ i 2)))) (if (<= c e) (if (<= (- e c) 2048) (for (d c (+ e 1)) (array-append out d)) (error "character range too large: "c"-"e)) (error "malformed character range: "c"-"e)) (set i (+ i 3))) (array-append out c) (set i (+ i 1))))) (while (< i l) (array-append out (string-at s i)) (set i (+ i 1))) (let ((c (array->string (array-sort out)))) c))) (define-function parser-stream-match-class (self class) (let ((obj (parser-stream-peek self))) (and (long? obj) (<= 0 (binary-search class obj <)) (parser-stream-next self)))) (define-function parser-stream-fail (self position) (set (-position self) position) ()) (define-function parser-stream-match-string (self str) (let ((pos (-position self)) (idx 0) (lim (string-length str))) (while (and (< idx lim) (parser-stream-match-object self (string-at str idx))) (set idx (+ idx 1))) (if (= idx lim) str (parser-stream-fail self pos)))) (define-function parser-stream-short-context (self) (let ((a (array)) (p (-position self))) (while (and (-tail (parser-stream-peek-token self)) (!= *end* (parser-stream-peek self)) (!= ?\n (parser-stream-peek self)) (!= ?\r (parser-stream-peek self))) (array-append a (parser-stream-next self))) (for (i 0 32) (if (and (!= *end* (parser-stream-peek self)) (!= ?\n (parser-stream-peek self)) (!= ?\r (parser-stream-peek self))) (array-append a (parser-stream-next self)) (set i 999))) ;;(array-do x a (println x)) (set (-position self) p) (array->string a))) (define-function parser-stream-context (self) (let ((a (array)) (p (-position self))) (while (and (-tail (parser-stream-peek-token self)) (!= *end* (parser-stream-peek self))) (array-append a (parser-stream-next self))) (and (> (array-length a) 0) (string-do c "" (array-append a c))) (for (i 0 32) (if (!= *end* (parser-stream-peek self)) (array-append a (parser-stream-next self)) (string-do c "" (array-append a c)) (set i 999))) ;;(array-do x a (println x)) (set (-position self) p) (array->string a))) (define-method $source-position () ($source-position self.source)) ;;;---------------- (unit-test "" (let ((s (parser-stream (string-stream "xhello"))) (c 0) (a (array))) (unit-assert (= ?x (parser-stream-peek s))) (unit-assert (= ?x (parser-stream-next s))) (unit-assert (= ?h (parser-stream-peek s))) (let ((p (-position s))) (while (!= *end* (set c (parser-stream-next s))) (array-append a c)) (unit-assert (= *end* (parser-stream-peek s))) (unit-assert (= *end* (parser-stream-next s))) (set (-position s) p) (unit-assert (= ?h (parser-stream-peek s))) (unit-assert (= ?h (parser-stream-next s))) (parser-stream-push s ?r) (unit-assert (= ?r (parser-stream-peek s))) (parser-stream-push s ?o) (unit-assert (= ?o (parser-stream-peek s))) (parser-stream-push s ?m) (unit-assert (= ?m (parser-stream-peek s))) (while (!= *end* (set c (parser-stream-next s))) (array-append a c)) (unit-assert (= "hellomorello" (array->string a))) (set (-position s) p) (unit-assert (= ?h (parser-stream-peek s))) (unit-assert (= ?h (parser-stream-next s))) (while (!= *end* (set c (parser-stream-next s))) (array-append a c)) (unit-assert (= "hellomorelloello" (array->string a))) (parser-stream-push s (list 'and "strings!" (list 'and (list 'lists)))) (parser-stream-push s 'symbols) (parser-stream-push s "yo dude...") (unit-assert (= "yo dude..." (parser-stream-next s))) (unit-assert (= 'symbols (parser-stream-next s))) (unit-assert (equal '(and "strings!" (and (lists))) (parser-stream-next s)))))) ;;;---------------------------------------------------------------- (define-structure (source)) (define-function parser-input-stream (source) (new source)) (define-method $at-end () ($at-end self.source)) (define-method $peek () (or ($peek self.source) *end*)) (define-method $next () (or ($next self.source) *end*)) (define-method $source-position () ($source-position self.source)) ;;;---------------------------------------------------------------- (define-structure (name body recursive?)) (define-function new- (name body) (let ((self (new ))) (set (-name self) name) (set (-body self) body) self)) (define-method do-print () (print "")) ;;;---------------------------------------------------------------- (define-structure (name base fields rules type)) (define-method do-print () (print "Grammar["(-name self)":"(-base self)(-fields self)"]={\n") (list-do rule (-rules self) (println " " rule)) (print " }")) (define-function grammar-add-rule (self rule) (let* ((name (car rule)) (body (cadr rule)) (rules (-rules self)) (pair (or (assq name rules) (car (set (-rules self) (cons (cons name body) rules)))))) (set-cdr pair (new- name body)))) (define-function grammar (name base fields rules) (let ((self (new ))) (set (-name self) name) (set (-base self) base) (set (-fields self) fields) (with-map grammar-add-rule self rules) self)) (define-function grammar-find-rule-or-nil (self name) (cdr (assq name (-rules self)))) (define-function grammar-find-rule (self name) (or (grammar-find-rule-or-nil self name) (error "rule '"name"' not found in grammar "(-name self)))) (define-function grammar-find-body (self name) (-body (grammar-find-rule self name))) ;;;---------------- (define-method $reachable-from (exp reached) ;;(dumpln "REACHABLE-FROM "exp) (and (pair? exp) (let ((op (car exp))) (and (!= op 'quasiquote) (!= op 'quote) (if (= 'match-rule (car exp)) (let ((name (cadr exp))) (or (member? name reached) (set reached ($reachable-from self (grammar-find-body self name) (cons name reached))))) (map (lambda (exp) (set reached ($reachable-from self exp reached))) (cdr exp)))))) reached) (define-method $warn-unreachable () (let ((start (grammar-find-rule-or-nil self 'start))) (and start (let ((reached ($reachable-from self (-body start) '(start)))) (list-do assoc self.rules (or (member? (-name (cdr assoc)) reached) (println "; WARNING: unreachable from start: "(-name (cdr assoc))))))))) (define-selector $consumes-input?) (define-method $consumes-input-all? (exps) (and exps (or ($consumes-input? self (car exps)) ($consumes-input-all? self (cdr exps))))) (define-method $consumes-input-first? (exps) (or (not exps) (and ($consumes-input? self (car exps)) ($consumes-input-first? self (cdr exps))))) (define-method $consumes-input? (exp) ;;(dumpln "CONSUMES-INPUT? "exp) (let ((op (car exp))) (cond ((= op 'match-object) 1) ((= op 'match-string) 1) ((= op 'match-class) 1) ((= op 'match-rule-in) 1) ;xxx THIS IS NOT RELIABLE xxx ((= op 'match-rule) ($consumes-input? self (grammar-find-body self (cadr exp)))) ((= op 'match-any) 1) ((= op 'result-expr) ()) ((= op 'match-list) 1) ((= op 'match-zero-one) ()) ((= op 'match-zero-more) ()) ((= op 'match-one-more) ($consumes-input? self (cadr exp))) ((= op 'make-span) ($consumes-input? self (cadr exp))) ((= op 'make-number) ($consumes-input? self (caddr exp))) ((= op 'make-radix-number) ($consumes-input? self (caddr exp))) ((= op 'make-symbol) ($consumes-input? self (cadr exp))) ((= op 'make-string) ($consumes-input? self (cadr exp))) ((= op 'assign-result) ($consumes-input? self (caddr exp))) ((= op 'peek-not) ($consumes-input? self (cadr exp))) ((= op 'peek-for) ($consumes-input? self (cadr exp))) ((= op 'match-all) ($consumes-input-all? self (cdr exp))) ((= op 'match-first) ($consumes-input-first? self (cdr exp))) (else (error "$consumes-input? does not know about "op))))) (define-selector $recursive-from?) (define-method $recursive-from-all? (exps name) (and exps (let ((hd (car exps))) (or ($recursive-from? self hd name) (and (not ($consumes-input? self hd)) ($recursive-from-all? self (cdr exps) name)))))) (define-method $recursive-from-first? (exps name) (and exps (or ($recursive-from? self (car exps) name) ($recursive-from-first? self (cdr exps) name)))) (define-method $recursive-from? (exp name) ;;(dumpln "RECURSIVE-FROM? "exp) (let ((op (car exp))) (cond ((= op 'match-object) ()) ((= op 'match-string) ()) ((= op 'match-class) ()) ((= op 'match-rule-in) ()) ;xxx THIS IS NOT RELIABLE xxx ((= op 'match-rule) (or (= name (cadr exp)) ($recursive-from? self (grammar-find-body self (cadr exp)) name))) ((= op 'match-any) ()) ((= op 'result-expr) ()) ((= op 'match-list) ()) ((= op 'match-zero-one) ($recursive-from? self (cadr exp) name)) ((= op 'match-zero-more) ($recursive-from? self (cadr exp) name)) ((= op 'match-one-more) ($recursive-from? self (cadr exp) name)) ((= op 'make-span) ($recursive-from? self (cadr exp) name)) ((= op 'make-number) ($recursive-from? self (caddr exp) name)) ((= op 'make-radix-number) ($recursive-from? self (caddr exp) name)) ((= op 'make-symbol) ($recursive-from? self (cadr exp) name)) ((= op 'make-string) ($recursive-from? self (cadr exp) name)) ((= op 'assign-result) ($recursive-from? self (caddr exp) name)) ((= op 'peek-not) ($recursive-from? self (cadr exp) name)) ((= op 'peek-for) ($recursive-from? self (cadr exp) name)) ((= op 'match-all) ($recursive-from-all? self (cdr exp) name)) ((= op 'match-first) ($recursive-from-first? self (cdr exp) name)) (else (error "$recursive-from? does not know about "op))))) (define-method $left-recursive? (rule) ($recursive-from? self (-body rule) (-name rule))) (define-method $warn-left-recursion () (list-do assoc self.rules (let ((rule (cdr assoc))) (and ($left-recursive? self rule) (set (-recursive? rule) 1) (println "; WARNING: left-recursive rule: "(-name (cdr assoc))))))) (define-method $sanity-check () ($warn-unreachable self) ($warn-left-recursion self) ) ;;;---------------------------------------------------------------- (define-structure (source result position)) (define-function parser (type stream) (let ((self (new type))) (set (-source self) stream) self)) (define-selector $start) (define-selector parse-from) (define-method parse-from (source rule) (set self.source (parser-stream source)) (rule self)) (define-selector parse) (define-function parse (self source) (parse-from self source $start)) (define-selector parse-all-from) (define-method parse-all-from (source rule) (set self.source (parser-stream source)) (let ((results (array))) (while (rule self) (array-append results self.result)) results)) (define-function parse-all (self source) (parse-all-from self source $start)) ;;;---------------------------------------------------------------- (define-class (grammar-name)) (define-function peg (name stream) (let ((self (new ))) (set (-source self) stream) (set (-grammar-name self) name) self)) ;;;---------------------------------------------------------------- (define-function %set-list-source (x y) (and (pair? x) (let () (and (pair? y) (set (-source x) (-source y))) (%set-list-source (cdr x) (cdr y)))) x) (define-function set-list-source (x pos) ;;(println "SET LIST "x" SOURCE "pos) (%set-list-source x pos) ;; ($source-position pos)) x) ;;;---------------------------------------------------------------- (define *outer* '(*outer*)) (define *inner* '(*inner*)) (define *recur* '(*recur*)) (define-structure (state result position)) (define-method do-print () (print "")) (define-function memo-set (self state result position) (with-instance-accessors (set self.result result) (set self.position position) (set self.state state))) (define %cookies 0) (define-form put (where key val) `(set ,where (cons (cons ,key ,val) ,where))) (define-form get (where key) `(cdr (assq ,key ,where))) (define-form del (where key) `(set ,where (%del ,where ,key))) (define-function %del (where key) (and (pair? where) (if (= key (caar where)) (cdr where) (cons (car where) (%del (cdr where) key))))) ;;;---------------------------------------------------------------- (define-form peg-define-rule (name type vars expr) (if vars `(define-method ,name ,type () (let ,vars ,expr)) `(define-method ,name ,type () ,expr))) (define *succeeded* '(*succeeded*)) (define *failed* '(*failed*)) (define *active* '(*active*)) (define *recurred* '(*recurred*)) (define-function peg-source-range-begin (self) (push (-position self) ($source-position (-source self)))) (define-function peg-source-range-end (self) (pop (-position self))) (define-function peg-invoke-rule-simply (rule name self) ;;(println "; simple "name) (peg-source-range-begin self) (let ((result (rule self))) (peg-source-range-end self) result)) (define-function peg-invoke-rule-with-memo (rule name self) ;;(println "; memoised "name" "self) (let* ((here (-position (-source self))) (memo (get (-notes here) name))) ;;(println "; memo "memo) (cond (memo (and (= *succeeded* (-state memo)) (let () (set (-result self) (-result memo)) (set (-position (-source self)) (-position memo))))) (else (put (-notes here) name (set memo (new ))) (if (peg-invoke-rule-simply rule name self) (memo-set memo *succeeded* (-result self) (-position (-source self))) (set (-state memo) *failed*) ()))))) (define-function peg-invoke-rule-with-recursion (rule name self) (let* ((stream (-source self)) (posn (-position stream)) (notes (-notes posn)) (memo (get notes name))) (if memo ;; this rule has already been entered at this position and has either succeeded, failed, or is in left-recursive iteration (let ((state (-state memo)) (result (-result memo))) (cond ((= state *succeeded*) (set (-result self) (-result memo)) (set (-position stream) (-position memo))) ((= state *active*) (set (-state memo) *recurred*) ()) (else ()))) ;; this rule has not been entered at this position (put (-notes posn) name (set memo (new *active* () posn))) (if (peg-invoke-rule-simply rule name self) ;; rule succeeded without recursion or entered recursion and found a non-recursive initial prefix (let ((state (-state memo))) (memo-set memo *succeeded* (-result self) (-position stream)) (if (= state *recurred*) (let () (set (-position stream) posn) ;; rewind to start of recursive match (while (and (peg-invoke-rule-simply rule name self) (token-preceeds (-position memo) (-position stream))) ;; grow the prefix recursively (set (-result memo) (-result self)) (set (-position memo) (-position stream)) (set (-position stream) posn)) (set (-result self) (-result memo)) ;; store the final result when recursion fails to grow prefix (set (-position stream) (-position memo))) (or (= state *active*) (error "unknown parser state after recursion: "state)))) (set (-state memo) *failed*) ())))) (define peg-invoke-rule peg-invoke-rule-simply) ;;(define rule-counter 0) (define-form peg-match-rule (name self) ;;(let ((qname (list 'quote (concat-symbol (format "%d." (incr rule-counter)) name)))) (let ((qname (list 'quote name))) `(peg-invoke-rule ,name ,qname ,self))) (define-function peg-disable-memoisation () (println "; PEG memoisation disabled") (set peg-invoke-rule peg-invoke-rule-simply)) (define-function peg-enable-memoisation () (println "; PEG memoisation enabled") (set peg-invoke-rule peg-invoke-rule-with-memo)) (define-function peg-enable-recursion () (println "; PEG recursion enabled") (set peg-invoke-rule peg-invoke-rule-with-recursion)) ;;(peg-enable-recursion) ;;;---------------------------------------------------------------- (define-function parse-stream (grammar rule stream) (let* ((s (parser-stream stream)) (p (parser grammar s))) (or (rule p) (let () (print "\nfailed to parse with gramamr "(name-of-type grammar)"."(-name rule)" near: ") (until (parser-stream-at-end stream) (print (format "%c" (parser-stream-next stream)))) (println "") (error "abort"))) (-result p))) (define-function parse-file (grammar rule path) (let* ((handle (or (open path) (error "cannot open: "path))) (stream (input-stream handle path)) (result (parse-stream grammar rule stream))) (close handle) result))