| 4e987026 |
;;; Macro definitions for the parser & lexer.
;;; This macro allows debugging of the lexer. Before releasing, this can
;;; be replaced by (begin ,@body) for faster code.
(define-syntax (trace-parser tag . body)
; `(begin
; (let* ((k (tracing-parse/entry ',tag))
; (res (begin ,@body)))
; (tracing-parse/exit ',tag k res)
; res))
(declare (ignore tag))
`(begin ,@body)
)
;;; Macros used by the lexer.
;;; The lexer used a macro, char-case, to dispatch on the syntactic catagory of
;;; a character. These catagories (processed at compile time) are defined
;;; here. Note that some of these definitions use the char-code
;;; directly and would need updating for different character sets.
(define *lex-definitions*
'((vtab 11) ; define by ascii code to avoid relying of the reader
(formfeed 12)
(whitechar #\newline #\space #\tab formfeed vtab)
(small #\a - #\z)
(large #\A - #\Z)
(digit #\0 - #\9)
(symbol #\! #\# #\$ #\% #\& #\* #\+ #\. #\/ #\< #\= #\> #\? #\@
#\\ #\^ #\|)
(presymbol #\- #\~)
(exponent #\e #\E)
(graphic large small digit
#\! #\" #\# #\$ #\% #\& #\' #\( #\) #\* #\+
#\, #\- #\. #\/ #\: #\; #\< #\= #\> #\? #\@
#\[ #\\ #\] #\^ #\_ #\` #\{ #\| #\} #\~)
(charesc #\a #\b #\f #\n #\r #\t #\v #\\ #\" #\' #\&)
(cntrl large #\@ #\[ #\\ #\] #\^ #\_)))
;;; The char-case macro is similar to case using characters to select.
;;; The following capabilities are added by char-case:
;;; pre-defined constants are denoted by symbols (defined above)
;;; ranges of characters are represented using -. For example,
;;; (#\a - #\z #\A - #\Z) denotes all alphabetics.
;;; numbers refer to the char code of a character.
;;; The generated code is optimized somewhat to take advantage of
;;; consecutive character ranges. With a little work, this could be
;;; implemented using jump tables someday.
(define-syntax (char-case exp . alts)
(expand-char-case exp alts))
(define (expand-char-case exp alts)
(let ((temp (gensym)))
`(let ((,temp ,exp))
,(expand-char-case1 temp alts))))
(define (expand-char-case1 temp alts)
(if (null? alts)
'()
(let* ((alt (car alts))
(test (car alt))
(body (cons 'begin (cdr alt)))
(rest (expand-char-case1 temp (cdr alts))))
(cond ((eq? test 'else)
body)
(else
`(if (or ,@(gen-char-tests temp
(if (pair? test) test (list test))))
,body
,rest))))))
(define (gen-char-tests temp tests)
(gen-char-tests-1 temp
(sort-list (gather-char-tests tests) (function char<?))))
(define (gen-char-tests-1 temp chars)
(cond ((null? chars)
'())
((long-enough-run? chars 3)
(gen-range-check temp (car chars) (car chars) (cdr chars)))
(else
`((char=? ,temp ',(car chars))
,@(gen-char-tests-1 temp (cdr chars))))))
(define (gen-range-check temp first current chars)
(if (and (pair? chars) (consec-chars? current (car chars)))
(gen-range-check temp first (car chars) (cdr chars))
`((and (char>=? ,temp ',first)
(char<=? ,temp ',current))
,@(gen-char-tests-1 temp chars))))
(define (consec-chars? c1 c2)
(eqv? (+ 1 (char->integer c1)) (char->integer c2)))
(define (long-enough-run? l n)
(or (eqv? n 1)
(and (pair? (cdr l))
(consec-chars? (car l) (cadr l))
(long-enough-run? (cdr l) (1- n)))))
(define (gather-char-tests tests)
(cond ((null? tests)
'())
((symbol? (car tests))
(let ((new-test (assq (car tests) *lex-definitions*)))
(if new-test
(gather-char-tests (append (cdr new-test) (cdr tests)))
(error "Unknown character class: ~A~%" (car tests)))))
((integer? (car tests))
(cons (integer->char (car tests))
(gather-char-tests (cdr tests))))
((and (pair? (cdr tests)) (eq? '- (cadr tests)))
(letrec ((fn (lambda (a z)
(if (char>? a z)
(gather-char-tests (cdddr tests))
(cons a (funcall
fn (integer->char
(+ 1 (char->integer a))) z))))))
(funcall fn (car tests) (caddr tests))))
((char? (car tests))
(cons (car tests) (gather-char-tests (cdr tests))))
(else
(error "Invalid selector in char-case: ~A~%" (car tests)))))
;;; This macro scans a list of characters on a given syntaxtic catagory.
;;; The current character is always included in the resulting list.
(define-syntax (scan-list-of char-type)
`(letrec ((test-next (lambda ()
(char-case *char*
(,char-type
(let ((c *char*))
(advance-char)
(cons c (funcall test-next))))
(else '())))))
(let ((c *char*))
(advance-char)
(cons c (funcall test-next)))))
;;; This macro tests for string equality in which the strings are
;;; represented by lists of characters. The comparisons are expanded
;;; inline (really just a little partial evaluation going on here!) for
;;; fast execution. The tok argument evaluate to a list of chars. The string
;;; argument must be a string constant, which is converted to characters
;;; as the macro expands.
(define-syntax (string=/list? tok string)
(let ((temp (gensym)))
`(let ((,temp ,tok))
,(expand-string=/list? temp (string->list string)))))
(define (expand-string=/list? var chars)
(if (null? chars)
`(null? ,var)
(let ((new-temp (gensym)))
`(and (pair? ,var)
(char=? (car ,var) ',(car chars))
(let ((,new-temp (cdr ,var)))
,(expand-string=/list? new-temp (cdr chars)))))))
;;; This macro extends the string equality defined above to search a
;;; list of reserved words quickly for keywords. It does this by a case
;;; dispatch on the first character of the string and then processing
;;; the remaining characters wirh string=/list. This would go a little
;;; faster with recursive char-case statements, but I'm a little too
;;; lazy at for this at the moment. If a keyword is found is emitted
;;; as a symbol. If not, the token string is emitted with the token
;;; type indicated. Assume the string being scanned is a list of
;;; chars assigned to a var. (Yeah - I know - I should add a gensym
;;; var for this argument!!).
(define-syntax (parse-reserved var token-type . reserved-words)
(let ((sorted-rws (sort-list reserved-words (function string<?))))
`(let ((thunk (lambda () (emit-token/string ',token-type ,var))))
(char-case (car ,var)
,@(expand-parse-reserved var
(group-by-first-char (list (car sorted-rws)) (cdr sorted-rws)))
(else (funcall thunk))))))
(define (group-by-first-char group rest)
(cond ((null? rest)
(list group))
((char=? (string-ref (car group) 0)
(string-ref (car rest) 0))
(group-by-first-char (append group (list (car rest))) (cdr rest)))
(else
(cons group (group-by-first-char (list (car rest)) (cdr rest))))))
(define (expand-parse-reserved var groups)
(if (null? groups)
'()
`((,(string-ref (caar groups) 0)
(cond ,@(expand-parse-reserved/group var (car groups))
(else (funcall thunk))))
,@(expand-parse-reserved var (cdr groups)))))
(define (expand-parse-reserved/group var group)
(if (null? group)
'()
`(((string=/list? (cdr ,var)
,(substring (car group) 1 (string-length (car group))))
(emit-token ',(string->symbol (car group))))
,@(expand-parse-reserved/group var (cdr group)))))
;;; The following macros are used by the parser.
;;; The primary macro used by the parser is token-case, which dispatches
;;; on the type of the current token (this is always *token* - unlike the
;;; lexer, no lookahead is provided; however, some of these dispatches are
;;; procedures that do a limited lookahead. The problem with lookahead is that
;;; the layout rule adds tokens which are not visible looking into the
;;; token stream directly.
;;; Unlike char-case, the token is normally advanced unless the selector
;;; includes `no-advance'. The final else also avoids advancing the token.
;;; In addition to raw token types, more complex types can be used. These
;;; are defined here. The construct `satisfies fn' calls the indicated
;;; function to determine whether the current token matches.
;;; If the token type to be matched is not a constant, the construct
;;; `unquote var' matches the current token against the type in the var.
(define *predefined-syntactic-catagories* '(
(+ satisfies at-varsym/+?)
(- satisfies at-varsym/-?)
(tycon no-advance conid)
(tyvar no-advance varid)
(var no-advance varid satisfies at-varsym/paren?)
(con no-advance conid satisfies at-consym/paren?)
(name no-advance var con)
(consym/paren no-advance satisfies at-consym/paren?)
(varsym? no-advance varsym)
(consym? no-advance consym)
(varid? no-advance varid)
(conid? no-advance conid)
(op no-advance varsym consym \`)
(varop no-advance varsym satisfies at-varid/quoted?)
(conop no-advance consym satisfies at-conid/quoted?)
(modid no-advance conid)
(literal no-advance integer float char string)
(numeric no-advance integer float)
(k no-advance integer)
(+k no-advance satisfies at-+k?)
(-n no-advance satisfies at--n?)
(apat-start no-advance varid conid literal _ \( \[ \~)
(pat-start no-advance - apat-start)
(atype-start no-advance tycon tyvar \( \[)
(aexp-start no-advance varid conid \( \[ literal)
))
;;; The format of token-case is
;;; (token-case
;;; (sel1 . e1) (sel2 . e2) ... [(else . en)])
;;; If the sel is a symbol it is the same as a singleton list: (@ x) = ((@) x)
;;; Warning: this generates rather poor code! Should be fixed up someday.
(define-syntax (token-case . alts)
`(cond ,@(map (function gen-token-case-alt) alts)))
(define (gen-token-case-alt alt)
(let ((test (car alt))
(code (cdr alt)))
(cond ((eq? test 'else)
`(else ,@code))
((symbol? test)
(gen-token-case-alt-1 (expand-catagories (list test)) code))
(else
(gen-token-case-alt-1 (expand-catagories test) code)))))
(define (expand-catagories terms)
(if (null? terms)
terms
(let ((a (assq (car terms) *predefined-syntactic-catagories*))
(r (expand-catagories (cdr terms))))
(if (null? a)
(cons (car terms) r)
(expand-catagories (append (cdr a) r))))))
(define (gen-token-case-alt-1 test code)
`((or ,@(gen-token-test test))
,@(if (memq 'no-advance test) '() '((advance-token)))
,@code))
(define (gen-token-test test)
(cond ((null? test)
'())
((eq? (car test) 'no-advance)
(gen-token-test (cdr test)))
((eq? (car test) 'unquote)
(cons `(eq? *token* ,(cadr test)) (gen-token-test (cddr test))))
((eq? (car test) 'satisfies)
(cons (list (cadr test)) (gen-token-test (cddr test))))
(else
(cons `(eq? *token* ',(car test)) (gen-token-test (cdr test))))))
;;; require-tok requires a specific token to be at the scanner. If it
;;; is found, the token is advanced over. Otherwise, the error
;;; routine is called.
(define-syntax (require-token tok error-handler)
`(token-case
(,tok '())
(else ,error-handler)))
;;; The save-parser-context macro captures the current line & file and
;;; attaches it to the ast node generated.
(define-syntax (save-parser-context . body)
(let ((temp1 (gensym))
(temp2 (gensym)))
`(let ((,temp1 (capture-current-line))
(,temp2 (begin ,@body)))
(setf (ast-node-line-number ,temp2) ,temp1)
,temp2)))
(define (capture-current-line)
(make source-pointer (line *current-line*) (file *current-file*)))
(define-syntax (push-decl-list decl place)
`(setf ,place (nconc ,place (list ,decl))))
|