summaryrefslogtreecommitdiffstats
path: root/prec.scm
diff options
context:
space:
mode:
Diffstat (limited to 'prec.scm')
-rwxr-xr-x[-rw-r--r--]prec.scm342
1 files changed, 164 insertions, 178 deletions
diff --git a/prec.scm b/prec.scm
index 19fb764..369ac20 100644..100755
--- a/prec.scm
+++ b/prec.scm
@@ -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))