diff options
Diffstat (limited to 'prec.scm')
| -rwxr-xr-x[-rw-r--r--] | prec.scm | 342 |
1 files changed, 164 insertions, 178 deletions
@@ -46,39 +46,25 @@ ; MACSYMA Reference Manual, Version Ten, ; Laboratory for Computer Science, MIT, 1983 -(require 'fluid-let) (require 'string-search) (require 'string-port) (require 'delay) +(require 'multiarg-apply) -(define *syn-rules* #f) ;Dynamically bound -(define *prec:port* #f) ;Dynamically bound ;@ (define *syn-defs* #f) -;; keeps track of input column so we can generate useful error displays. -(define tok:column 0) -(define (tok:peek-char) (peek-char *prec:port*)) -(define (tok:read-char) - (let ((c (read-char *prec:port*))) - (if (or (eqv? c #\newline) (eof-object? c)) - (set! tok:column 0) - (set! tok:column (+ 1 tok:column))) +(define (tok:peek-char dyn) (peek-char (cadr dyn))) +(define (tok:read-char dyn) + (let ((c (read-char (cadr dyn)))) + (set-car! (cddddr dyn) + (if (or (eqv? c #\newline) (eof-object? c)) + 0 + (+ 1 (car (cddddr dyn))))) c)) -;@ -(define (tok:bump-column pos . ports) - ((lambda (thunk) - (cond ((null? ports) (thunk)) - (else (fluid-let ((*prec:port* (car ports)) - (prec:token #f)) - (thunk))))) - (lambda () - (cond ((eqv? #\newline (tok:peek-char)) - (tok:read-char))) ;to do newline - (set! tok:column (+ tok:column pos))))) - -(define (prec:warn . msgs) - (do ((j (+ -1 tok:column) (+ -8 j))) + +(define (prec:warn dyn . msgs) + (do ((j (+ -1 (car (cddddr dyn))) (+ -8 j))) ((> 8 j) (do ((i j (+ -1 i))) ((>= 0 i) @@ -102,38 +88,40 @@ ;@ (define (tok:char-group group chars chars-proc) (map (lambda (token) -;;; (let ((oldlexrec (tok:lookup *syn-defs* token))) -;;; (cond ((or (not oldlexrec) (eqv? (tok:cc oldlexrec) group))) -;;; (else (math:warn 'cc-of token 'redefined-to- group)))) +;;; (let ((oldlexrec (tok:lookup *syn-defs* token))) +;;; (cond ((or (not oldlexrec) (eqv? (tok:cc oldlexrec) group))) +;;; (else (math:warn 'cc-of token 'redefined-to- group)))) (cons token (tok:make-rec group chars-proc))) (cond ((string? chars) (string->list chars)) ((char? chars) (list chars)) (else chars)))) -(define (tokenize) - (let* ((char (tok:read-char)) - (rec (tok:lookup *syn-rules* char)) +(define (tokenize dyn) + (let* ((char (tok:read-char dyn)) + (rec (tok:lookup (car dyn) char)) (proc (and rec (tok:cc rec))) (clist (list char))) (cond ((not proc) char) ((procedure? proc) - (do ((cl clist (begin (set-cdr! cl (list (tok:read-char))) (cdr cl)))) - ((proc (tok:peek-char)) - ((or (tok:sfp rec) list->string) clist)))) - ((eqv? 0 proc) (tokenize)) + (do ((cl clist (begin (set-cdr! cl (list (tok:read-char dyn))) (cdr cl)))) + ((proc (tok:peek-char dyn)) + ((or (tok:sfp rec) (lambda (dyn l) (list->string l))) + dyn + clist)))) + ((eqv? 0 proc) (tokenize dyn)) (else - (do ((cl clist (begin (set-cdr! cl (list (tok:read-char))) (cdr cl)))) - ((not (let* ((prec (tok:lookup *syn-rules* (tok:peek-char))) + (do ((cl clist (begin (set-cdr! cl (list (tok:read-char dyn))) (cdr cl)))) + ((not (let* ((prec (tok:lookup (car dyn) (tok:peek-char dyn))) (cclass (and prec (tok:cc prec)))) (or (eqv? cclass proc) (eqv? cclass (+ -1 proc))))) - ((tok:sfp rec) clist))))))) + ((tok:sfp rec) dyn clist))))))) ;;; PREC:NUD is the null denotation (function and arguments to call when no -;;; unclaimed tokens). +;;; unclaimed tokens). ;;; PREC:LED is the left denotation (function and arguments to call when -;;; unclaimed token is on left). +;;; unclaimed token is on left). ;;; PREC:LBP is the left binding power of this LED. It is the first ;;; argument position of PREC:LED @@ -180,10 +168,7 @@ (if (pair? toks) toks (list toks)))) ;;; Produce dynamically augmented grammars. -(define (prec:process-binds binds rules) - (if (and #f (not (null? binds)) (eq? #t (car binds))) - (cdr binds) - (append binds rules))) +(define prec:process-binds append) ;;(define (prec:replace-rules) some-sort-of-magic-cookie) @@ -198,74 +183,76 @@ (define (prec:nofix tk sop . binds) (prec:make-nud tk prec:parse-nofix sop (apply append binds))) -(define (prec:parse-nofix self sop binds) - (set! *syn-rules* (prec:process-binds binds *syn-rules*)) - (prec:call-or-list (or sop (prec:symbolfy self)))) +(define (prec:parse-nofix dyn self sop binds) + (let ((dyn (cons (prec:process-binds binds (car dyn)) (cdr dyn)))) + (prec:call-or-list (or sop (prec:symbolfy self))))) ;@ (define (prec:prefix tk sop bp . binds) (prec:make-nud tk prec:parse-prefix sop bp (apply append binds))) -(define (prec:parse-prefix self sop bp binds) - (fluid-let ((*syn-rules* (prec:process-binds binds *syn-rules*))) - (prec:call-or-list (or sop (prec:symbolfy self)) (prec:parse1 bp)))) +(define (prec:parse-prefix dyn self sop bp binds) + (let ((dyn (cons (prec:process-binds binds (car dyn)) (cdr dyn)))) + (prec:call-or-list (or sop (prec:symbolfy self)) (prec:parse1 dyn bp)))) ;@ (define (prec:infix tk sop lbp bp . binds) (prec:make-led tk lbp prec:parse-infix sop bp (apply append binds))) -(define (prec:parse-infix left self lbp sop bp binds) - (fluid-let ((*syn-rules* (prec:process-binds binds *syn-rules*))) - (prec:call-or-list (or sop (prec:symbolfy self)) left (prec:parse1 bp)))) +(define (prec:parse-infix dyn left self lbp sop bp binds) + (let ((dyn (cons (prec:process-binds binds (car dyn)) (cdr dyn)))) + (prec:call-or-list (or sop (prec:symbolfy self)) left (prec:parse1 dyn bp)))) ;@ (define (prec:nary tk sop bp) (prec:make-led tk bp prec:parse-nary sop bp)) -(define (prec:parse-nary left self lbp sop bp) +(define (prec:parse-nary dyn left self lbp sop bp) (prec:apply-or-cons (or sop (prec:symbolfy self)) - (cons left (prec:parse-list self bp)))) + (cons left (prec:parse-list dyn self bp)))) ;@ (define (prec:postfix tk sop lbp . binds) (prec:make-led tk lbp prec:parse-postfix sop (apply append binds))) -(define (prec:parse-postfix left self lbp sop binds) - (set! *syn-rules* (prec:process-binds binds *syn-rules*)) - (prec:call-or-list (or sop (prec:symbolfy self)) left)) +(define (prec:parse-postfix dyn left self lbp sop binds) + (let ((dyn (cons (prec:process-binds binds (car dyn)) (cdr dyn)))) + (prec:call-or-list (or sop (prec:symbolfy self)) left))) ;@ (define (prec:prestfix tk sop bp . binds) (prec:make-nud tk prec:parse-rest sop bp (apply append binds))) -(define (prec:parse-rest self sop bp binds) - (fluid-let ((*syn-rules* (prec:process-binds binds *syn-rules*))) - (prec:apply-or-cons (or sop (prec:symbolfy self)) (prec:parse-list #f bp)))) +(define (prec:parse-rest dyn self sop bp binds) + (let ((dyn (cons (prec:process-binds binds (car dyn)) (cdr dyn)))) + (prec:apply-or-cons (or sop (prec:symbolfy self)) (prec:parse-list dyn #f bp)))) ;@ (define (prec:commentfix tk stp match . binds) (append (prec:make-nud tk prec:parse-nudcomment stp match (apply append binds)) (prec:make-led tk 220 prec:parse-ledcomment stp match (apply append binds)))) -(define (prec:parse-nudcomment self stp match binds) - (fluid-let ((*syn-rules* (prec:process-binds binds *syn-rules*))) - (tok:read-through-comment stp match) - (prec:advance) - (cond ((prec:delim? (force prec:token)) #f) - (else (prec:parse1 prec:bp))))) -(define (prec:parse-ledcomment left lbp self stp match binds) - (fluid-let ((*syn-rules* (prec:process-binds binds *syn-rules*))) - (tok:read-through-comment stp match) - (prec:advance) +(define (prec:parse-nudcomment dyn self stp match binds) + (let ((dyn (cons (prec:process-binds binds (car dyn)) (cdr dyn)))) + (tok:read-through-comment dyn stp match) + (prec:advance dyn) + (cond ((prec:delim? dyn (force (caddr dyn))) #f) + (else (prec:parse1 dyn (cadddr dyn)))))) + +(define (prec:parse-ledcomment dyn left lbp self stp match binds) + (let ((dyn (cons (prec:process-binds binds (car dyn)) (cdr dyn)))) + (tok:read-through-comment dyn stp match) + (prec:advance dyn) left)) -(define (tok:read-through-comment stp match) + +(define (tok:read-through-comment dyn stp match) (set! match (if (char? match) (string match) (prec:de-symbolfy match))) (cond ((procedure? stp) (let* ((len #f) (str (call-with-output-string - (lambda (sp) - (set! len (find-string-from-port? - match *prec:port* - (lambda (c) (display c sp) #f))))))) + (lambda (sp) + (set! len (find-string-from-port? + match (cadr dyn) + (lambda (c) (display c sp) #f))))))) (stp (and len (substring str 0 (- len (string-length match))))))) - (else (find-string-from-port? match *prec:port*)))) + (else (find-string-from-port? match (cadr dyn))))) ;@ (define (prec:matchfix tk sop sep match . binds) (define sep-lbp 0) @@ -273,26 +260,25 @@ sop sep-lbp sep match (apply append (prec:delim match) binds))) -(define (prec:parse-matchfix self sop sep-lbp sep match binds) - (fluid-let ((*syn-rules* (prec:process-binds binds *syn-rules*))) - (cond (sop (prec:apply-or-cons - sop (prec:parse-delimited sep sep-lbp match))) - ((equal? (force prec:token) match) - (prec:warn 'expression-missing) - (prec:advance) +(define (prec:parse-matchfix dyn self sop sep-lbp sep match binds) + (let ((dyn (cons (prec:process-binds binds (car dyn)) (cdr dyn)))) + (cond (sop (prec:apply-or-cons sop (prec:parse-delimited dyn sep sep-lbp match))) + ((equal? (force (caddr dyn)) match) + (prec:warn dyn 'expression-missing) + (prec:advance dyn) '?) - (else (let ((ans (prec:parse1 0))) ;just parenthesized expression - (cond ((equal? (force prec:token) match) - (prec:advance)) - ((prec:delim? (force prec:token)) - (prec:warn 'mismatched-delimiter (force prec:token) + (else (let ((ans (prec:parse1 dyn 0))) ;just parenthesized expression + (cond ((equal? (force (caddr dyn)) match) + (prec:advance dyn)) + ((prec:delim? dyn (force (caddr dyn))) + (prec:warn dyn 'mismatched-delimiter (force (caddr dyn)) 'not match) - (prec:advance)) - (else (prec:warn 'delimiter-expected--ignoring-rest - (force prec:token) 'expected match + (prec:advance dyn)) + (else (prec:warn dyn 'delimiter-expected--ignoring-rest + (force (caddr dyn)) 'expected match 'or-delimiter) - (do () ((prec:delim? (force prec:token))) - (prec:parse1 0)))) + (do () ((prec:delim? dyn (force (caddr dyn)))) + (prec:parse1 dyn 0)))) ans))))) ;@ (define (prec:inmatchfix tk sop sep match lbp . binds) @@ -301,115 +287,115 @@ sop sep-lbp sep match (apply append (prec:delim match) binds))) -(define (prec:parse-inmatchfix left self lbp sop sep-lbp sep match binds) - (fluid-let ((*syn-rules* (prec:process-binds binds *syn-rules*))) - (prec:apply-or-cons - sop (cons left (prec:parse-delimited sep sep-lbp match))))) +(define (prec:parse-inmatchfix dyn left self lbp sop sep-lbp sep match binds) + (let ((dyn (cons (prec:process-binds binds (car dyn)) (cdr dyn)))) + (prec:apply-or-cons sop (cons left (prec:parse-delimited dyn sep sep-lbp match))))) ;;;; Here is the code which actually parses. -(define prec:bp #f) ;dynamically bound -(define prec:token #f) -(define (prec:advance) - (set! prec:token (delay (tokenize)))) -(define (prec:advance-return-last) - (let ((last (and prec:token (force prec:token)))) - (prec:advance) +(define (prec:advance dyn) + (set-car! (cddr dyn) (delay (tokenize dyn)))) +(define (prec:advance-return-last dyn) + (let ((last (and (caddr dyn) (force (caddr dyn))))) + (prec:advance dyn) last)) -(define (prec:nudcall self) - (let ((pob (prec:nudf *syn-rules* self))) +(define (prec:nudcall dyn self) + (let ((pob (prec:nudf (car dyn) self))) (cond (pob (let ((proc (car pob))) - (cond ((procedure? proc) (apply proc self (cdr pob))) + (cond ((procedure? proc) (apply proc dyn self (cdr pob))) (proc (cons proc (cdr pob))) (else '?)))) - ((char? self) (prec:warn 'extra-separator) - (prec:advance) - (prec:nudcall (force prec:token))) + ((char? self) (prec:warn dyn 'extra-separator) + (prec:advance dyn) + (prec:nudcall dyn (force (caddr dyn)))) ((string? self) (string->symbol self)) (else self)))) -(define (prec:ledcall left self) - (let* ((pob (prec:ledf *syn-rules* self))) - (apply (cadr pob) left self (cdr pob)))) +(define (prec:ledcall dyn left self) + (let* ((pob (prec:ledf (car dyn) self))) + (apply (cadr pob) dyn left self (cdr pob)))) ;;; PREC:PARSE1 is the heart. -(define (prec:parse1 bp) - (fluid-let ((prec:bp bp)) - (do ((left (prec:nudcall (prec:advance-return-last)) - (prec:ledcall left (prec:advance-return-last)))) - ((or (>= bp 200) ;to avoid unneccesary lookahead - (>= bp (or (prec:lbp *syn-rules* (force prec:token)) 0)) - (not left)) - left)))) - -(define (prec:delim? token) - (or (eof-object? token) (<= (or (prec:lbp *syn-rules* token) 220) 0))) - -(define (prec:parse-list sep bp) - (cond ((prec:delim? (force prec:token)) - (prec:warn 'expression-missing) +(define (prec:parse1 dyn bp) + (do ((left (prec:nudcall dyn (prec:advance-return-last dyn)) + (prec:ledcall dyn left (prec:advance-return-last dyn)))) + ((or (>= bp 200) ;to avoid unneccesary lookahead + (>= bp (or (prec:lbp (car dyn) (force (caddr dyn))) 0)) + (not left)) + left))) + +(define (prec:delim? dyn token) + (or (eof-object? token) (<= (or (prec:lbp (car dyn) token) 220) 0))) + +(define (prec:parse-list dyn sep bp) + (cond ((prec:delim? dyn (force (caddr dyn))) + (prec:warn dyn 'expression-missing) '(?)) (else - (let ((f (prec:parse1 bp))) - (cons f (cond ((equal? (force prec:token) sep) - (prec:advance) - (cond ((equal? (force prec:token) sep) - (prec:warn 'expression-missing) - (prec:advance) - (cons '? (prec:parse-list sep bp))) - ((prec:delim? (force prec:token)) - (prec:warn 'expression-missing) + (let ((f (prec:parse1 dyn bp))) + (cons f (cond ((equal? (force (caddr dyn)) sep) + (prec:advance dyn) + (cond ((equal? (force (caddr dyn)) sep) + (prec:warn dyn 'expression-missing) + (prec:advance dyn) + (cons '? (prec:parse-list dyn sep bp))) + ((prec:delim? dyn (force (caddr dyn))) + (prec:warn dyn 'expression-missing) '(?)) - (else (prec:parse-list sep bp)))) - ((prec:delim? (force prec:token)) '()) - ((not sep) (prec:parse-list sep bp)) - ((prec:delim? sep) (prec:warn 'separator-missing) - (prec:parse-list sep bp)) + (else (prec:parse-list dyn sep bp)))) + ((prec:delim? dyn (force (caddr dyn))) '()) + ((not sep) (prec:parse-list dyn sep bp)) + ((prec:delim? dyn sep) (prec:warn dyn 'separator-missing) + (prec:parse-list dyn sep bp)) (else '()))))))) -(define (prec:parse-delimited sep bp delim) - (cond ((equal? (force prec:token) sep) - (prec:warn 'expression-missing) - (prec:advance) - (cons '? (prec:parse-delimited sep bp delim))) - ((prec:delim? (force prec:token)) - (if (not (equal? (force prec:token) delim)) - (prec:warn 'mismatched-delimiter (force prec:token) +(define (prec:parse-delimited dyn sep bp delim) + (cond ((equal? (force (caddr dyn)) sep) + (prec:warn dyn 'expression-missing) + (prec:advance dyn) + (cons '? (prec:parse-delimited dyn sep bp delim))) + ((prec:delim? dyn (force (caddr dyn))) + (if (not (equal? (force (caddr dyn)) delim)) + (prec:warn dyn 'mismatched-delimiter (force (caddr dyn)) 'expected delim)) - (if (not sep) (prec:warn 'expression-missing)) - (prec:advance) + (if (not sep) (prec:warn dyn 'expression-missing)) + (prec:advance dyn) (if sep '() '(?))) - (else (let ((ans (prec:parse-list sep bp))) - (cond ((equal? (force prec:token) delim)) - ((prec:delim? (force prec:token)) - (prec:warn 'mismatched-delimiter (force prec:token) + (else (let ((ans (prec:parse-list dyn sep bp))) + (cond ((equal? (force (caddr dyn)) delim)) + ((prec:delim? dyn (force (caddr dyn))) + (prec:warn dyn 'mismatched-delimiter (force (caddr dyn)) 'expecting delim)) - (else (prec:warn 'delimiter-expected--ignoring-rest - (force prec:token) '...) - (do () ((prec:delim? (force prec:token))) - (prec:parse1 bp)))) - (prec:advance) + (else (prec:warn dyn 'delimiter-expected--ignoring-rest + (force (caddr dyn)) '...) + (do () ((prec:delim? dyn (force (caddr dyn)))) + (prec:parse1 dyn bp)))) + (prec:advance dyn) ans)))) ;@ -(define (prec:parse grammar delim . port) +(define (prec:parse grammar delim column . ports) + (define port (if (null? ports) (current-input-port) (car ports))) (set! delim (prec:de-symbolfy delim)) - (fluid-let ((*syn-rules* (append (prec:delim delim) grammar)) - (*prec:port* (if (null? port) (current-input-port) (car port))) - (prec:token prec:token)) - (prec:advance) ; setup prec:token with first token - (cond ((eof-object? (force prec:token)) (force prec:token)) - ((equal? (force prec:token) delim) #f) + (let ((dyn (list (append (prec:delim delim) grammar) + port + #f + 0 + column))) + (prec:advance dyn) ; setup prec:token with first token + (cond ((eof-object? (force (caddr dyn))) (force (caddr dyn))) + ((equal? (force (caddr dyn)) delim) #f) (else - (let ((ans (prec:parse1 0))) - (cond ((eof-object? (force prec:token))) - ((equal? (force prec:token) delim)) - (else (prec:warn 'delimiter-expected--ignoring-rest - (force prec:token) 'not delim) - (do () ((or (equal? (force prec:token) delim) - (eof-object? (force prec:token)))) - (prec:advance)))) + (let ((ans (prec:parse1 dyn 0))) + (cond ((eof-object? (force (caddr dyn)))) + ((equal? (force (caddr dyn)) delim)) + (else (prec:warn dyn + 'delimiter-expected--ignoring-rest + (force (caddr dyn)) 'not delim) + (do () ((or (equal? (force (caddr dyn)) delim) + (eof-object? (force (caddr dyn))))) + (prec:advance dyn)))) ans))))) ;@ (define tok:decimal-digits "0123456789") @@ -424,7 +410,7 @@ ;;;;The parse tables. ;;; Definitions accumulate in top-level variable *SYN-DEFS*. -(set! *syn-defs* '()) ;Make sure *SYN-DEFS* is empty. +(set! *syn-defs* '()) ;Make sure *SYN-DEFS* is empty. ;;; Ignore Whitespace characters. (prec:define-grammar (tok:char-group 0 tok:whitespaces #f)) |