summaryrefslogtreecommitdiffstats
path: root/prec.scm
diff options
context:
space:
mode:
Diffstat (limited to 'prec.scm')
-rw-r--r--prec.scm72
1 files changed, 35 insertions, 37 deletions
diff --git a/prec.scm b/prec.scm
index 47807ad..3d57318 100644
--- a/prec.scm
+++ b/prec.scm
@@ -8,7 +8,7 @@
;1. Any copy made of this software must include this copyright notice
;in full.
;
-;2. I have made no warrantee or representation that the operation of
+;2. I have made no warranty or representation that the operation of
;this software will be error-free, and I am under no obligation to
;provide any services, by way of maintenance, update, or otherwise.
;
@@ -51,9 +51,10 @@
(require 'string-port)
(require 'delay)
-(define *syn-defs* #f)
(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)
@@ -64,14 +65,18 @@
(set! tok:column 0)
(set! tok:column (+ 1 tok:column)))
c))
+;@
(define (tok:bump-column pos . ports)
((lambda (thunk)
(cond ((null? ports) (thunk))
- (else (fluid-let ((*prec:port* (car 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)))
((> 8 j)
@@ -94,7 +99,7 @@
#f
(let ((pair (assv char alist)))
(and pair (cdr pair)))))
-
+;@
(define (tok:char-group group chars chars-proc)
(map (lambda (token)
;;; (let ((oldlexrec (tok:lookup *syn-defs* token)))
@@ -159,10 +164,10 @@
(else obj)))
;;;Calls to set up tables.
-
+;@
(define (prec:define-grammar . synlsts)
(set! *syn-defs* (append (apply append synlsts) *syn-defs*)))
-
+;@
(define (prec:make-led toks . args)
(map (lambda (tok)
(cons (cons 'led (prec:de-symbolfy tok))
@@ -186,50 +191,57 @@
;;; utility functions called during parsing. The utility functions
;;; (prec:parse-*) could be incorportated into the defining commands,
;;; but tracing these functions is useful for debugging.
-
+;@
(define (prec:delim tk)
(prec:make-led tk 0 #f))
-
+;@
(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: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: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:nary tk sop bp)
(prec:make-led tk bp prec:parse-nary sop bp))
+
(define (prec:parse-nary left self lbp sop bp)
(prec:apply-or-cons (or sop (prec:symbolfy self))
(cons left (prec:parse-list 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: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: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)
@@ -254,12 +266,13 @@
(lambda (c) (display c sp) #f)))))))
(stp (and len (substring str 0 (- len (string-length match)))))))
(else (find-string-from-port? match *prec:port*))))
-
+;@
(define (prec:matchfix tk sop sep match . binds)
(define sep-lbp 0)
(prec:make-nud tk prec:parse-matchfix
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
@@ -281,12 +294,13 @@
(do () ((prec:delim? (force prec:token)))
(prec:parse1 0))))
ans)))))
-
+;@
(define (prec:inmatchfix tk sop sep match lbp . binds)
(define sep-lbp 0)
(prec:make-led tk lbp prec:parse-inmatchfix
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
@@ -378,11 +392,12 @@
(prec:parse1 bp))))
(prec:advance)
ans))))
-
+;@
(define (prec:parse grammar delim . port)
(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: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)
@@ -396,7 +411,7 @@
(eof-object? (force prec:token))))
(prec:advance))))
ans)))))
-
+;@
(define tok:decimal-digits "0123456789")
(define tok:upper-case "ABCDEFGHIJKLMNOPQRSTUVWXYZ")
(define tok:lower-case "abcdefghijklmnopqrstuvwxyz")
@@ -422,27 +437,10 @@
(prec:define-grammar (tok:char-group 0 (integer->char 26) #f))
)))
-;;; Save these convenient definitions.
+;;;@ Save these convenient definitions.
(define *syn-ignore-whitespace* *syn-defs*)
(set! *syn-defs* '())
-(define (prec:trace)
- (require 'trace)
- (trace prec:parse prec:parse1
- prec:parse-delimited prec:parse-list
- prec:call-or-list prec:apply-or-cons
- ;;tokenize prec:advance-return-last prec:advance
- prec:nudcall prec:ledcall
- prec:parse-nudcomment prec:parse-ledcomment
- prec:parse-delimited prec:parse-list
- prec:parse-nary prec:parse-rest
- prec:parse-matchfix prec:parse-inmatchfix
- prec:parse-prefix prec:parse-infix prec:parse-postfix
- ;;prec:delim?
- ;;prec:ledf prec:nudf prec:lbp
- )
- (set! *qp-width* 333))
-
;;(begin (trace-all "prec.scm") (set! *qp-width* 333))
;;(pretty-print (grammar-read-tab (get-grammar 'standard)))
;;(prec:trace)