diff options
Diffstat (limited to 'prec.scm')
| -rw-r--r-- | prec.scm | 72 |
1 files changed, 35 insertions, 37 deletions
@@ -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) |