diff --git a/collects/eopl/datatype.rkt b/collects/eopl/datatype.rkt index 5555935c1b..df6973818d 100644 --- a/collects/eopl/datatype.rkt +++ b/collects/eopl/datatype.rkt @@ -1,342 +1,266 @@ ;; NOTE: datatypes are currently transparent, for the sake of EoPL's ;; use of `equal?' -#lang racket +#lang racket/base -(require (for-syntax "private/utils.rkt")) +(require (for-syntax racket/base "private/utils.rkt")) -(define-syntax define-datatype - (lambda (stx) - (syntax-case stx () - [(_ name pred-name - (variant-name (field-name field-pred) ...) - ...) - (let ([variant-names (syntax->list (syntax (variant-name ...)))]) - ;; More syntax checks... - (unless (identifier? (syntax name)) - (raise-syntax-error #f - "expected an identifier for the datatype name" - stx (syntax name))) - (unless (identifier? (syntax pred-name)) - (raise-syntax-error #f - "expected an identifier for the predicate name" - stx (syntax pred-name))) - (for-each (lambda (vt fields) - (unless (identifier? vt) - (raise-syntax-error - 'cases - "expected an identifier for the variant name" - stx vt)) - (for-each (lambda (field) - (unless (identifier? field) - (raise-syntax-error - 'cases - "expected an identifier for the field name" - stx field))) - (syntax->list fields))) - variant-names - (syntax->list (syntax ((field-name ...) ...)))) - ;; Count the fields for each variant: - (with-syntax ([(variant-field-count ...) - (map (lambda (n) - (datum->syntax (quote-syntax here) n #f)) - (map length - (map - syntax->list - (syntax->list - (syntax ((field-name ...) ...))))))] - [(variant? ...) - (map (lambda (vn) - (datum->syntax - vn - (string->uninterned-symbol - (format "~a?" (syntax-e vn))))) - variant-names)] - [(variant-accessor ...) - (map (lambda (vn) - (datum->syntax - vn - (string->uninterned-symbol - (format "~a-accessor" (syntax-e vn))))) - variant-names)] - [(variant-mutator ...) - (generate-temporaries variant-names)] - [(make-variant ...) - (generate-temporaries variant-names)] - [(struct:variant ...) - (generate-temporaries variant-names)] - [(make-variant-name ...) - (map (lambda (vn) - (datum->syntax - vn - (string->symbol - (format "make-~a" (syntax-e vn))))) - variant-names)]) - (syntax - (begin - (define-syntax name - ;; Note: we're back to the transformer environment, here. - ;; Also, this isn't a transformer function, so any direct - ;; use of the name will trigger a syntax error. The name - ;; can be found by `syntax-local-value', though. - (let ([cert (syntax-local-certifier #t)]) - (make-dt (cert (syntax pred-name)) - (list - (make-vt (cert (syntax variant-name)) - (cert (syntax variant?)) - (cert (syntax variant-accessor)) - variant-field-count) - ...)))) - ;; Bind the predicate and selector functions: - (define-values (pred-name - variant-name ... - variant? ... - variant-accessor ...) - ;; Create a new structure for the datatype (using the - ;; datatype name in `struct', so it prints nicely). - (let-values ([(struct:x make-x x? acc mut) - (make-struct-type 'name #f 0 0 #f null (make-inspector))]) - (let-values ([(struct:variant make-variant variant? - variant-accessor variant-mutator) - (make-struct-type 'variant-name struct:x variant-field-count 0 - #f - null - (make-inspector))] - ...) - ;; User-available functions: - (values - x? ;; The datatype predicate - ;; Create the constructor functions: - (let ([vname (quote variant-name)]) - (let ([variant-name - (lambda (field-name ...) - (unless (field-pred field-name) - (error vname - "bad value for ~a field: ~e" - (quote field-name) - field-name)) - ... - (make-variant field-name ...))]) - variant-name)) - ... - variant? ... - variant-accessor ...)))) - ;; Compatibility bindings - (define-values (make-variant-name ...) (values variant-name ...))))))] - [(_ name pred-name variant ...) - ;; Must be a bad variant... - (for-each (lambda (variant) - (syntax-case variant () - [(variant-name field ...) - (let ([name (syntax variant-name)]) - (unless (identifier? name) - (raise-syntax-error - #f - "expected an identifier for the variant name" - stx - name)) - ;; Must be a bad field: - (for-each (lambda (field) - (syntax-case field () - [(field-name field-pred) - (let ([name (syntax field-name)]) - (unless (identifier? name) - (raise-syntax-error - #f - "expected an identifier for the field name" - stx - name)))] - [_else - (raise-syntax-error - #f - "expected a field name followed by a predicate expression, all in parentheses" - stx - field)])) - (syntax->list (syntax (field ...)))))] - [_else +(define-syntax (define-datatype stx) + (syntax-case stx () + [(_ name pred-name + (variant-name (field-name field-pred) ...) + ...) + (let ([variant-names (syntax->list #'(variant-name ...))]) + ;; More syntax checks... + (unless (identifier? #'name) + (raise-syntax-error + #f "expected an identifier for the datatype name" stx #'name)) + (unless (identifier? #'pred-name) + (raise-syntax-error + #f "expected an identifier for the predicate name" stx #'pred-name)) + (for ([vt (in-list variant-names)] + [fields (in-list (syntax->list #'((field-name ...) ...)))]) + (unless (identifier? vt) + (raise-syntax-error + 'cases "expected an identifier for the variant name" stx vt)) + (for ([field (in-list (syntax->list fields))]) + (unless (identifier? field) + (raise-syntax-error + 'cases "expected an identifier for the field name" stx field)))) + ;; Count the fields for each variant: + (with-syntax ([(variant-field-count ...) + (for/list ([x (in-list (syntax->list + #'((field-name ...) ...)))]) + (datum->syntax (quote-syntax here) + (length (syntax->list x)) + #f))] + [(variant? ...) + (for/list ([vn (in-list variant-names)]) + (datum->syntax + vn + (string->uninterned-symbol + (format "~a?" (syntax-e vn)))))] + [(variant-accessor ...) + (for/list ([vn (in-list variant-names)]) + (datum->syntax + vn + (string->uninterned-symbol + (format "~a-accessor" (syntax-e vn)))))] + [(variant-mutator ...) + (generate-temporaries variant-names)] + [(make-variant ...) + (generate-temporaries variant-names)] + [(struct:variant ...) + (generate-temporaries variant-names)] + [(make-variant-name ...) + (for/list ([vn (in-list variant-names)]) + (datum->syntax + vn + (string->symbol + (format "make-~a" (syntax-e vn)))))]) + #'(begin + (define-syntax name + ;; Note: we're back to the transformer environment, here. + ;; Also, this isn't a transformer function, so any direct + ;; use of the name will trigger a syntax error. The name + ;; can be found by `syntax-local-value', though. + (let ([cert (syntax-local-certifier #t)]) + (make-dt (cert #'pred-name) + (list (make-vt (cert #'variant-name) + (cert #'variant?) + (cert #'variant-accessor) + variant-field-count) + ...)))) + ;; Bind the predicate and selector functions: + (define-values (pred-name + variant-name ... + variant? ... + variant-accessor ...) + ;; Create a new structure for the datatype (using the + ;; datatype name in `struct', so it prints nicely). + (let-values ([(struct:x make-x x? acc mut) + (make-struct-type 'name #f 0 0 #f null (make-inspector))]) + (let-values ([(struct:variant make-variant variant? + variant-accessor variant-mutator) + (make-struct-type 'variant-name struct:x variant-field-count 0 + #f + null + (make-inspector))] + ...) + ;; User-available functions: + (values + x? ;; The datatype predicate + ;; Create the constructor functions: + (let* ([vname 'variant-name] + [variant-name + (lambda (field-name ...) + (unless (field-pred field-name) + (error vname "bad value for ~a field: ~e" + 'field-name field-name)) + ... + (make-variant field-name ...))]) + variant-name) + ... + variant? ... + variant-accessor ...)))) + ;; Compatibility bindings + (define-values (make-variant-name ...) (values variant-name ...)))))] + [(_ name pred-name variant ...) + ;; Must be a bad variant... + (for ([variant (in-list (syntax->list #'(variant ...)))]) + (syntax-case variant () + [(variant-name field ...) + (let ([name #'variant-name]) + (unless (identifier? name) + (raise-syntax-error + #f "expected an identifier for the variant name" stx name)) + ;; Must be a bad field: + (for ([field (in-list (syntax->list #'(field ...)))]) + (syntax-case field () + [(field-name field-pred) + (let ([name #'field-name]) + (unless (identifier? name) + (raise-syntax-error + #f "expected an identifier for the field name" stx name)))] + [_else + (raise-syntax-error + #f "expected a field name followed by a predicate expression, all in parentheses" stx field)])))] + [_else + (raise-syntax-error + #f "expected a variant name followed by a sequence of field declarations, all in parentheses" stx variant)]))] + [(_ name) + (raise-syntax-error + #f "missing predicate name and variant clauses" stx)])) + +(define-syntax (cases stx) + (syntax-case stx () + [(_ datatype expr + clause + ...) + ;; Get datatype information: + (let ([dt (and (identifier? #'datatype) + (syntax-local-value #'datatype (lambda () #f)))]) + (unless (dt? dt) + (raise-syntax-error 'cases "not a datatype name" stx #'datatype)) + + ;; Parse clauses: + (define-values (vts field-idss bodys else-body) + (let loop ([clauses (syntax->list #'(clause ...))] + [saw-cases null]) + (if (null? clauses) + (values null null null #f) + (let ([clause (car clauses)]) + (syntax-case* clause () + (lambda (a b) + (and (eq? (syntax-e b) 'else) + (not (identifier-binding b)))) + [(variant (field-id ...) body0 body1 ...) + (let* ([variant #'variant] + [vt (ormap (lambda (dtv) + (define vt-name (vt-name-stx dtv)) + (and (free-identifier=? variant vt-name) + dtv)) + (dt-variants dt))] + [orig-variant (and vt (vt-name-stx vt))]) + (unless orig-variant (raise-syntax-error #f - "expected a variant name followed by a sequence of field declarations, all in parentheses" + (format "not a variant of `~a'" + (syntax->datum #'datatype)) stx - variant)])) - (syntax->list (syntax (variant ...))))] - [(_ name) - (raise-syntax-error - #f - "missing predicate name and variant clauses" - stx)]))) + variant)) -(define-syntax cases - (lambda (stx) - (syntax-case stx () - [(_ datatype expr - clause - ...) - ;; Get datatype information: - (let ([dt (and (identifier? (syntax datatype)) - (syntax-local-value (syntax datatype) (lambda () #f)))]) - (unless (dt? dt) - (raise-syntax-error - 'cases - "not a datatype name" - stx - (syntax datatype))) + (let ([field-ids (syntax->list #'(field-id ...))]) + (for ([fid (in-list field-ids)]) + (unless (identifier? fid) + (raise-syntax-error + #f "expected an identifier for a field" stx fid))) + (let ([dtv (variant-assq variant (dt-variants dt))]) + (unless (= (length field-ids) (vt-field-count dtv)) + (raise-syntax-error + #f + (format + "variant case `~a' for `~a' has wrong field count (expected ~a, found ~a)" + (syntax->datum variant) + (syntax->datum #'datatype) + (vt-field-count dtv) + (length field-ids)) + stx + clause))) - ;; Parse clauses: - (let-values ([(vts field-idss bodys else-body) - (let loop ([clauses (syntax->list (syntax (clause ...)))][saw-cases null]) - (cond - [(null? clauses) - (values null null null #f)] - [else - (let ([clause (car clauses)]) - (syntax-case* clause () - (lambda (a b) - (and (eq? (syntax-e b) 'else) - (not (identifier-binding b)))) - [(variant (field-id ...) body0 body1 ...) - (let* ([variant (syntax variant)] - [vt - (ormap (lambda (dtv) - (let ([vt-name (vt-name-stx dtv)]) - (and (free-identifier=? variant vt-name) - dtv))) - (dt-variants dt))] - [orig-variant (and vt (vt-name-stx vt))]) - (unless orig-variant - (raise-syntax-error - #f - (format "not a variant of `~a'" - (syntax->datum (syntax datatype))) - stx - variant)) + ;; Check for duplicate local field ids: + (let ([dup (check-duplicate-identifier field-ids)]) + (when dup + (raise-syntax-error + #f "duplicate field identifier" stx dup))) - (let ([field-ids (syntax->list (syntax (field-id ...)))]) - (for-each (lambda (fid) - (unless (identifier? fid) - (raise-syntax-error - #f - "expected an identifier for a field" - stx - fid))) - field-ids) - (let ([dtv (variant-assq variant (dt-variants dt))]) - (unless (= (length field-ids) - (vt-field-count dtv)) - (raise-syntax-error - #f - (format - "variant case `~a' for `~a' has wrong field count (expected ~a, found ~a)" - (syntax->datum variant) - (syntax->datum (syntax datatype)) - (vt-field-count dtv) - (length field-ids)) - stx - clause))) + ;; Check for redundant case: + (when (memq orig-variant saw-cases) + (raise-syntax-error #f "duplicate case" stx clause)) - ;; Check for duplicate local field ids: - (let ([dup (check-duplicate-identifier field-ids)]) - (when dup - (raise-syntax-error - #f - "duplicate field identifier" - stx - dup))) + ;; This clause is ok: + (let-values ([(vts idss bodys else) + (loop (cdr clauses) (cons orig-variant saw-cases))]) + (values (cons vt vts) + (cons field-ids idss) + (cons #'(begin body0 body1 ...) bodys) + else))))] + [(else body0 body1 ...) + (begin + (unless (null? (cdr clauses)) + (raise-syntax-error + #f "else clause must be last" stx clause)) + (values null null null #'(begin body0 body1 ...)))] + [_else (raise-syntax-error #f "bad clause" stx clause)]))))) + ;; Missing any variants? + (unless (or else-body (= (length vts) (length (dt-variants dt)))) + (define here (map vt-name-stx vts)) + (define missing + (let loop ([l (dt-variants dt)]) + (cond [(null? l) ""] + [(ormap (lambda (i) (free-identifier=? (vt-name-stx (car l)) i)) here) + (loop (cdr l))] + [else (format " ~a~a" + (syntax-e (vt-name-stx (car l))) + (loop (cdr l)))]))) + (raise-syntax-error + #f + (format "missing cases for the following variants:~a" missing) + stx)) - ;; Check for redundant case: - (when (memq orig-variant saw-cases) - (raise-syntax-error - #f - "duplicate case" - stx - clause)) + ;; Create the result: + (with-syntax ([pred (dt-pred-stx dt)] + [(variant? ...) (map vt-predicate-stx vts)] + [((field-extraction ...) ...) + (for/list ([vt (in-list vts)]) + (with-syntax ([accessor (vt-accessor-stx vt)]) + (let loop ([n 0]) + (if (= n (vt-field-count vt)) + null + (cons #`(accessor v #,n) + (loop (add1 n)))))))] + [((field-id ...) ...) field-idss] + [(body ...) bodys] + [else-body (or else-body + #'(error 'cases "no variant case matched"))]) + #'(let ([v expr]) + (if (not (pred v)) + (error 'cases "not a ~a: ~s" (quote datatype) v) + (cond + [(variant? v) + (let ([field-id field-extraction] ...) + body)] + ... + [else else-body])))))])) - ;; This clause is ok: - (let-values ([(vts idss bodys else) - (loop (cdr clauses) (cons orig-variant saw-cases))]) - (values (cons vt vts) - (cons field-ids idss) - (cons (syntax (begin body0 body1 ...)) bodys) - else))))] - [(else body0 body1 ...) - (begin - (unless (null? (cdr clauses)) - (raise-syntax-error - #f - "else clause must be last" - stx - clause)) - (values null null null (syntax (begin body0 body1 ...))))] - [_else (raise-syntax-error - #f - "bad clause" - stx - clause)]))]))]) - - ;; Missing any variants? - (unless (or else-body - (= (length vts) (length (dt-variants dt)))) - (let* ([here (map vt-name-stx vts)] - [missing (let loop ([l (dt-variants dt)]) - (cond - [(null? l) ""] - [(ormap (lambda (i) (free-identifier=? (vt-name-stx (car l)) i)) here) - (loop (cdr l))] - [else - (format " ~a~a" - (syntax-e (vt-name-stx (car l))) - (loop (cdr l)))]))]) - (raise-syntax-error - #f - (format "missing cases for the following variants:~a" missing) - stx))) - - ;; Create the result: - (with-syntax ([pred (dt-pred-stx dt)] - [(variant? ...) (map vt-predicate-stx vts)] - [((field-extraction ...) ...) - (map (lambda (vt) - (with-syntax ([accessor (vt-accessor-stx vt)]) - (let loop ([n 0]) - (if (= n (vt-field-count vt)) - null - (cons (with-syntax ([n n]) - (syntax (accessor v n))) - (loop (add1 n))))))) - vts)] - [((field-id ...) ...) field-idss] - [(body ...) bodys] - [else-body (or else-body - (syntax - (error 'cases "no variant case matched")))]) - (syntax - (let ([v expr]) - (if (not (pred v)) - (error 'cases "not a ~a: ~s" (quote datatype) v) - (cond - [(variant? v) - (let ([field-id field-extraction] ...) - body)] - ... - [else else-body])))))))]))) - -(define-syntax provide-datatype - (lambda (stx) - (syntax-case stx () - [(_ datatype) - (let ([dt (syntax-local-value (syntax datatype) (lambda () #f))]) - (unless (dt? dt) - (raise-syntax-error - #f - "not a datatype name" - stx - (syntax datatype))) - (with-syntax ([pred (dt-pred-stx dt)] - [(orig-variant ...) - (map vt-name-stx (dt-variants dt))]) - (syntax - (provide datatype - pred - orig-variant ...))))]))) +(define-syntax (provide-datatype stx) + (syntax-case stx () + [(_ datatype) + (let ([dt (syntax-local-value #'datatype (lambda () #f))]) + (unless (dt? dt) + (raise-syntax-error #f "not a datatype name" stx #'datatype)) + (with-syntax ([pred (dt-pred-stx dt)] + [(orig-variant ...) (map vt-name-stx (dt-variants dt))]) + #'(provide datatype pred orig-variant ...)))])) (provide define-datatype cases provide-datatype) diff --git a/collects/eopl/info.rkt b/collects/eopl/info.rkt index 957181140a..fc44ec3863 100644 --- a/collects/eopl/info.rkt +++ b/collects/eopl/info.rkt @@ -3,4 +3,3 @@ (require string-constants) (define scribblings '(("eopl.scrbl" () (teaching -20)))) - diff --git a/collects/eopl/private/sllboth.rkt b/collects/eopl/private/sllboth.rkt index 90db24dc56..65e574f496 100644 --- a/collects/eopl/private/sllboth.rkt +++ b/collects/eopl/private/sllboth.rkt @@ -5,18 +5,18 @@ ;; S-expression. (provide sllgen:action-preference-list - sllgen:action? - sllgen:make-tester-regexp - sllgen:make-or-regexp - sllgen:make-arbno-regexp - sllgen:make-concat-regexp - sllgen:tester-regexp? - sllgen:or-regexp? - sllgen:arbno-regexp? - sllgen:concat-regexp? - sllgen:tester-symbol-list - sllgen:make-char-tester - sllgen:tester?) + sllgen:action? + sllgen:make-tester-regexp + sllgen:make-or-regexp + sllgen:make-arbno-regexp + sllgen:make-concat-regexp + sllgen:tester-regexp? + sllgen:or-regexp? + sllgen:arbno-regexp? + sllgen:concat-regexp? + sllgen:tester-symbol-list + sllgen:make-char-tester + sllgen:tester?) (define sllgen:action-preference-list '(string make-string symbol make-symbol number make-number skip)) @@ -29,42 +29,42 @@ (symbol? (cdr action))))) (define sllgen:make-tester-regexp (lambda (x) x)) - (define sllgen:make-or-regexp (lambda (res) (cons 'or res))) - (define sllgen:make-arbno-regexp (lambda (re) (list 'arbno re))) + (define sllgen:make-or-regexp (lambda (res) (cons 'or res))) + (define sllgen:make-arbno-regexp (lambda (re) (list 'arbno re))) (define sllgen:make-concat-regexp (lambda (rs) (cons 'concat rs))) - (define sllgen:tester-regexp? - (lambda (x) + (define sllgen:tester-regexp? + (lambda (x) (and (sllgen:tester? x) (lambda (f) (f x))))) (define sllgen:or-regexp? (lambda (x) (and (eq? (car x) 'or) - (lambda (f) (f (cdr x)))))) + (lambda (f) (f (cdr x)))))) (define sllgen:arbno-regexp? (lambda (x) (and (eq? (car x) 'arbno) - (lambda (f) (f (cadr x)))))) + (lambda (f) (f (cadr x)))))) (define sllgen:concat-regexp? (lambda (x) (and (eq? (car x) 'concat) - (lambda (f) (f (cdr x)))))) + (lambda (f) (f (cdr x)))))) (define sllgen:tester-symbol-list '(letter digit any whitespace)) - (define sllgen:make-char-tester - (lambda (char) + (define sllgen:make-char-tester + (lambda (char) (and (or (char? char) - (error 'scanner-generation "illegal character ~s" char)) - char))) + (error 'scanner-generation "illegal character ~s" char)) + char))) (define sllgen:tester? (lambda (v) (or (char? v) - (member v sllgen:tester-symbol-list) - (and (pair? v) - (eq? (car v) 'not) - (pair? (cdr v)) - (char? (cadr v)))))) + (member v sllgen:tester-symbol-list) + (and (pair? v) + (eq? (car v) 'not) + (pair? (cdr v)) + (char? (cadr v)))))) diff --git a/collects/eopl/private/slldef.rkt b/collects/eopl/private/slldef.rkt index 125b234eb3..0a2b4ee4c4 100644 --- a/collects/eopl/private/slldef.rkt +++ b/collects/eopl/private/slldef.rkt @@ -1,4 +1,4 @@ #lang racket - ;; A compile-time table shared by eopl and sllgen: - (define sllgen-def (make-hasheq)) - (provide sllgen-def) +;; A compile-time table shared by eopl and sllgen: +(define sllgen-def (make-hasheq)) +(provide sllgen-def) diff --git a/collects/eopl/private/sllgen.rkt b/collects/eopl/private/sllgen.rkt index e5d47484ac..fa4b066a81 100644 --- a/collects/eopl/private/sllgen.rkt +++ b/collects/eopl/private/sllgen.rkt @@ -11,24 +11,23 @@ "../datatype.rkt" "sllboth.rkt" "slldef.rkt" - (for-syntax racket/base - "sllboth.rkt" - "slldef.rkt")) + (for-syntax racket/base "sllboth.rkt" "slldef.rkt")) -(provide sllgen:make-string-parser - sllgen:make-stream-parser - sllgen:make-stream-scanner - sllgen:make-string-scanner - sllgen:make-define-datatypes - sllgen:show-define-datatypes +(provide sllgen:make-string-parser + sllgen:make-stream-parser + sllgen:make-stream-scanner + sllgen:make-string-scanner + sllgen:make-define-datatypes + sllgen:show-define-datatypes sllgen:list-define-datatypes) -'(let ((time-stamp "Time-stamp: <2000-09-25 11:48:47 wand>")) - (display (string-append - "sllgen.scm " - (substring time-stamp 13 29) - (string #\newline)))) +#; ; this was originally quoted, probably intended as a comment +(let ((time-stamp "Time-stamp: <2000-09-25 11:48:47 wand>")) + (display (string-append + "sllgen.scm " + (substring time-stamp 13 29) + (string #\newline)))) (define sllgen:make-rep-loop (lambda (prompt eval-fn stream-parser) @@ -44,7 +43,7 @@ (loop stream)) (lambda () #t)))))) -;; **************************************************************** +;; **************************************************************** ;; Table of contents: @@ -78,7 +77,7 @@ ;; top.s ;; user-level entry points -(begin-for-syntax +(begin-for-syntax ;; Gets a table: maybe immediate, maybe from a top-level definition (define (get-table srcstx t what) (let ([def (and (identifier? t) @@ -89,11 +88,11 @@ [(quote v) (syntax->datum (syntax v))] [_else - (raise-syntax-error #f + (raise-syntax-error #f (format "bad ~a specification" what) srcstx t)])))) - + (define (make-one maker) (lambda (stx) (syntax-case stx () @@ -102,7 +101,7 @@ (get-table stx (syntax scanner-spec) "scanner") (get-table stx (syntax grammar) "grammar") stx)]))) - + (define sllgen:make-string-parser-maker (lambda (scanner-spec grammar srcstx) (with-syntax ((parser-maker (sllgen:make-parser-maker grammar srcstx)) @@ -112,8 +111,7 @@ grammar) scanner-spec)))) (syntax (make-string-parser parser-maker scanner-maker))))) - - + (define sllgen:make-stream-parser-maker (lambda (scanner-spec grammar srcstx) (with-syntax ((parser-maker (sllgen:make-parser-maker grammar srcstx)) @@ -123,8 +121,7 @@ grammar) scanner-spec)))) (syntax (make-stream-parser parser-maker scanner-maker))))) - - + (define sllgen:make-stream-scanner-maker (lambda (scanner-spec grammar srcstx) (sllgen:make-scanner-maker @@ -132,7 +129,7 @@ (sllgen:grammar->string-literal-scanner-spec grammar) scanner-spec)))) - + (define sllgen:make-string-scanner-maker (lambda (scanner-spec grammar srcstx) (with-syntax ((scanner-maker (sllgen:make-stream-scanner-maker scanner-spec grammar srcstx))) @@ -140,7 +137,7 @@ (lambda (string) (sllgen:stream->list (scanner (sllgen:string->stream string))))))))) - + (define sllgen:make-define-datatypes-maker (lambda (scanner-spec grammar srcstx) (with-syntax ((datatype-definitions @@ -149,48 +146,46 @@ (sllgen:build-define-datatype-definitions scanner-spec grammar) srcstx))) (syntax (begin . datatype-definitions))))) - + (define sllgen:show-define-datatypes-maker (lambda (scanner-spec grammar srcstx) (with-syntax ((datatype-definitions (sllgen:build-define-datatype-definitions scanner-spec grammar))) (syntax (begin (for-each - pretty-print + pretty-print 'datatype-definitions)))))) - - - + (define sllgen:list-define-datatypes-maker (lambda (scanner-spec grammar srcstx) (with-syntax ((datatype-definitions (sllgen:build-define-datatype-definitions scanner-spec grammar))) (syntax 'datatype-definitions)))) - - + + ;; **************************************************************** ;; **************************************************************** - - ;; parser-gen.scm - + + ;; parser-gen.scm + ;; Steps in parser generation: - + ;; 1. Eliminate arbno's by making new nonterms with goto's and - ;; emit-list's. - + ;; emit-list's. + ;; 2. Factor productions with common prefixes (not in this version). - + ;; 3. Compute first and follow sets - + ;; 4. Compute prediction table & generate actions - + ;; **************************************************************** - + ;; parser = token-stream * ((tree * token * token-stream) -> ans) -> ans ;; token-stream should be terminated by end-marker token. - + (define (qq-ize table srcstx) - (list 'quasiquote + (list 'quasiquote (map (lambda (prod) (cons (car prod) (map (lambda (case) @@ -198,7 +193,7 @@ (map (lambda (act) (if (eq? (car act) 'reduce) (list 'reduce - (list 'unquote + (list 'unquote (datum->syntax srcstx (cadr act)))) @@ -206,8 +201,8 @@ (cdr case)))) (cdr prod)))) table))) - - (define sllgen:make-parser-maker + + (define sllgen:make-parser-maker (lambda (grammar srcstx) (sllgen:grammar-check-syntax grammar) (sllgen:initialize-non-terminal-table! grammar) @@ -220,10 +215,9 @@ (lambda (token-stream k) ; k : (tree * token * token-stream) -> ans (sllgen:find-production 'start-symbol parse-table '() '() token-stream k))))))) - - + (define the-table 'ignored) - + (define sllgen:build-parse-table (lambda (grammar) (let* ((g (sllgen:eliminate-arbnos-from-productions grammar)) @@ -241,16 +235,16 @@ (set! the-table table) (sllgen:check-table table) table))) - - + + ;; **************************************************************** - + ;; syntax.s : concrete syntax for grammars, etc. - + ;; **************************************************************** - + ;; Concrete Syntax for grammars - + ;; ::= ( ...) ;; nonterm of first prod is ;; start symbol. ;; ::= (lhs rhs action) @@ -261,28 +255,28 @@ ;; rhs ::= (rhs-item ...) ;; ;; rhs-item ::= string | symbol | (ARBNO . rhs) | (SEPARATED-LIST nt token) - ;; + ;; ;; action ::= symbol | EMIT-LIST | (GOTO lhs) ;; EMIT-LIST and (GOTO lhs) are not allowed in user input. - + ;; **************************************************************** - + ;; Auxiliaries for dealing with syntax of grammars - + ;; need to define sllgen:grammar-check-syntax - + (define sllgen:check (lambda (test format . args) (lambda (obj) (or (test obj) (apply error `(parser-generation ,format . ,args)))))) - + (define sllgen:grammar-check-syntax (lambda (grammar) ((sllgen:list-of sllgen:production-check-syntax) grammar))) - + (define sllgen:production-check-syntax (lambda (production) ((sllgen:tuple-of @@ -293,12 +287,12 @@ "action of production not a symbol: ~s" production)) production))) - + (define sllgen:rhs-check-syntax (lambda (production) - (sllgen:list-of + (sllgen:list-of (sllgen:rhs-item-check-syntax production)))) - + (define sllgen:rhs-item-check-syntax (lambda (production) (lambda (rhs-item) @@ -314,25 +308,24 @@ "illegal rhs item ~s in production ~s" rhs-item production) rhs-item)))) - + (define sllgen:really-separated-list? (lambda (rhs-item) (and (pair? rhs-item) (eq? (car rhs-item) 'separated-list) (> (length rhs-item) 2) (sllgen:rhs-check-syntax (cdr rhs-item)) - (let - ; ((last-item (car (last-pair rhs-item)))) - ((last-item (sllgen:last rhs-item))) + (let ; ((last-item (car (last-pair rhs-item)))) + ((last-item (sllgen:last rhs-item))) (or (symbol? last-item) (string? last-item)))))) - + (define sllgen:pair-of (lambda (pred1 pred2) (lambda (obj) (and (pair? obj) (pred1 (car obj)) (pred2 (cdr obj)))))) - + (define sllgen:list-of (lambda (pred) (lambda (obj) @@ -340,7 +333,7 @@ (and (pair? obj) (pred (car obj)) ((sllgen:list-of pred) (cdr obj))))))) - + (define sllgen:tuple-of (lambda preds (lambda (obj) @@ -350,7 +343,7 @@ (and (pair? obj) ((car preds) (car obj)) (loop (cdr preds) (cdr obj)))))))) - + (define sllgen:either (lambda preds (lambda (obj) @@ -359,77 +352,75 @@ ((null? preds) #f) (((car preds) obj) #t) (else (loop (cdr preds)))))))) - - - (define sllgen:grammar->productions + + (define sllgen:grammar->productions (lambda (gram) gram)) ; nothing else now, but this ; might change - + (define sllgen:grammar->start-symbol (lambda (gram) (sllgen:production->lhs - (car - (sllgen:grammar->productions gram))))) - + (car (sllgen:grammar->productions gram))))) + (define sllgen:make-production (lambda (lhs rhs action) (list lhs rhs action))) - + (define sllgen:production->lhs car) (define sllgen:production->rhs cadr) (define sllgen:production->action caddr) - + (define sllgen:productions->non-terminals (lambda (productions) (map sllgen:production->lhs productions))) - + (define sllgen:arbno? (lambda (rhs-item) (and (pair? rhs-item) (eq? (car rhs-item) 'arbno)))) - + (define sllgen:arbno->rhs cdr) - + (define sllgen:separated-list? (lambda (rhs-item) (and (pair? rhs-item) (eq? (car rhs-item) 'separated-list) (> (length rhs-item) 2)))) - + ;; (separated-list rhs-item ... separator) - + (define sllgen:separated-list->nonterm cadr) - + (define sllgen:separated-list->separator (lambda (item) (let loop ((items (cdr item))) (cond ((null? (cdr items)) (car items)) (else (loop (cdr items))))))) - + (define sllgen:separated-list->rhs (lambda (item) (let loop ((items (cdr item))) (cond ((null? (cdr items)) '()) (else (cons (car items) (loop (cdr items)))))))) - + (define sllgen:goto-action (lambda (lhs) (list 'goto lhs))) - + (define sllgen:emit-list-action (lambda () '(emit-list))) - + (define sllgen:grammar->string-literals ; apply this after arbnos have ; been eliminated. (lambda (grammar) (apply append - (map + (map (lambda (production) (sllgen:rhs->string-literals (sllgen:production->rhs production))) grammar)))) - + (define sllgen:rhs->string-literals (lambda (rhs) (let loop ((rhs rhs)) @@ -438,26 +429,25 @@ ((string? (car rhs)) (cons (car rhs) (loop (cdr rhs)))) ((pair? (car rhs)) (append (loop (cdar rhs)) (loop (cdr rhs)))) (else (loop (cdr rhs))))))) - + (define sllgen:grammar->string-literal-scanner-spec (lambda (grammar) (let ((class (sllgen:gensym 'literal-string))) (map (lambda (string) (list class (list string) 'make-string)) (sllgen:grammar->string-literals grammar))))) - + ;; **************************************************************** - + ;; updatable associative tables - + ;; table ::= ((symbol . list) ...) - - + (define sllgen:make-initial-table ; makes table with all entries ; initialized to empty (lambda (symbols) (map (lambda (v) (cons v (box null))) symbols))) - + (define sllgen:add-value-to-table! (lambda (table key value) (let ((pair (assq key table))) @@ -466,11 +456,11 @@ (begin (set-box! (cdr pair) (cons value (unbox (cdr pair)))) #t))))) - + (define sllgen:table-lookup (lambda (table key) (unbox (cdr (assq key table))))) - + (define sllgen:uniq (lambda (l) (if (null? l) '() @@ -478,23 +468,22 @@ (if (member (car l) z) z (cons (car l) z)))))) - + (define sllgen:union (lambda (s1 s2) ; s1 and s2 already unique (if (null? s1) s2 (if (member (car s1) s2) (sllgen:union (cdr s1) s2) (cons (car s1) (sllgen:union (cdr s1) s2)))))) - + ;; this is only called with '(), so the eqv? is ok. (define sllgen:rember (lambda (a s) - (cond + (cond ((null? s) s) ((eqv? a (car s)) (cdr s)) (else (cons (car s) (sllgen:rember a (cdr s))))))) - - + (define sllgen:gensym (let ((n 0)) (lambda (s) @@ -502,30 +491,30 @@ (let ((s (if (string? s) s (symbol->string s)))) (string->symbol (string-append s (number->string n))))))) - - + + ;; **************************************************************** - + ;; a table for keeping the arity of the generated nonterminals for - ;; arbno. - + ;; arbno. + (define sllgen:arbno-table '()) - + (define sllgen:arbno-initialize-table! (lambda () (set! sllgen:arbno-table '()))) - + (define sllgen:arbno-add-entry! (lambda (sym val) (set! sllgen:arbno-table (cons (cons sym val) sllgen:arbno-table)))) - + (define sllgen:arbno-assv (lambda (ref) (assv ref sllgen:arbno-table))) - + (define sllgen:non-terminal-table '()) - + (define sllgen:initialize-non-terminal-table! (lambda (productions) (set! sllgen:non-terminal-table '()) @@ -534,23 +523,23 @@ (sllgen:non-terminal-add! (sllgen:production->lhs prod))) productions))) - + (define sllgen:non-terminal-add! (lambda (sym) (when (not (memv sym sllgen:non-terminal-table)) (set! sllgen:non-terminal-table (cons sym sllgen:non-terminal-table))))) - + (define sllgen:non-terminal? (lambda (sym) (memv sym sllgen:non-terminal-table))) - + ;; **************************************************************** - + ;; eliminate-arbno.s - + ;; replaces (ARBNO lhs) items with new productions - + (define sllgen:eliminate-arbnos-from-rhs (lambda (rhs k) ;; returns to its continuation the new rhs and the list of @@ -572,7 +561,7 @@ local-rhs (lambda (new-local-rhs new-local-prods) (k - (cons new-nonterm new-rhs) + (cons new-nonterm new-rhs) (cons (sllgen:make-production new-nonterm '() (sllgen:emit-list-action)) @@ -605,18 +594,18 @@ (list (sllgen:make-production ; g1 -> e new-nonterm1 '() - (sllgen:emit-list-action)) + (sllgen:emit-list-action)) (sllgen:make-production ; g1 -> B1 B2 (goto g3) - new-nonterm1 + new-nonterm1 new-local-rhs (sllgen:goto-action new-nonterm3)) (sllgen:make-production ; g2 -> B1 B2 (goto g3). - new-nonterm2 + new-nonterm2 new-local-rhs - (sllgen:goto-action new-nonterm3)) + (sllgen:goto-action new-nonterm3)) (sllgen:make-production ; g3 -> e (emit-list) new-nonterm3 - '() (sllgen:emit-list-action)) + '() (sllgen:emit-list-action)) (sllgen:make-production ; g3 -> C (goto g2) new-nonterm3 (list separator) @@ -628,7 +617,7 @@ (lambda (new-rhs new-prods) (k (cons (car rhs) new-rhs) new-prods))))))) - + (define sllgen:eliminate-arbnos-from-production (lambda (production) ;; returns list of productions @@ -636,13 +625,13 @@ (sllgen:production->rhs production) (lambda (new-rhs new-prods) (let ((new-production - (sllgen:make-production + (sllgen:make-production (sllgen:production->lhs production) new-rhs (sllgen:production->action production)))) (cons new-production (sllgen:eliminate-arbnos-from-productions new-prods))))))) - + (define sllgen:eliminate-arbnos-from-productions (lambda (productions) (let loop ((productions productions)) @@ -651,7 +640,7 @@ (append (sllgen:eliminate-arbnos-from-production (car productions)) (loop (cdr productions))))))) - + (define sllgen:rhs-data-length (lambda (rhs) (let ((report-error @@ -692,32 +681,32 @@ ; (eopl:printf "found error\n") (report-error rhs-item "unrecognized item")))))))) (loop rhs))))) - + ;; **************************************************************** - + ;; first-and-follow.s - + ;; calculate first and follow sets - + ;; base conditions: - + ;; A -> a ... => a in first(A) ;; A -> () => nil in first(A) - + ;; closure conditions: - + ;; A -> (B1 ... Bk c ...) & nil in first(B1)...first(Bk) => c in first(A) ;; A -> (B1 ... Bk C ...) & nil in first(B1)...first(Bk) & c in first(C) => - ;; c in first(A) + ;; c in first(A) ;; A -> (B1 ... Bk) & nil in first(B1)...first(Bk) => nil in first(A) - + (define sllgen:first-table (lambda (productions) (let* ((non-terminals (sllgen:uniq (map sllgen:production->lhs productions))) (table (sllgen:make-initial-table non-terminals))) (letrec - ((loop + ((loop ;; initialize with the base conditions and return the ;; productions to be considered for the closure (lambda (productions) @@ -725,7 +714,7 @@ ((null? productions) '()) ((null? (sllgen:production->rhs (car productions))) ;; A -> () => nil in first(A) - (sllgen:add-value-to-table! table + (sllgen:add-value-to-table! table (sllgen:production->lhs (car productions)) '()) (loop (cdr productions))) @@ -745,9 +734,9 @@ (car productions))))))))) (let ((closure-productions (loop productions))) (sllgen:iterate-over-first-table table productions - non-terminals)))))) - - + non-terminals)))))) + + (define sllgen:iterate-over-first-table (lambda (table productions non-terminals) (let* ((changed? '**uninitialized**) @@ -765,28 +754,28 @@ (cond ((null? rhs) ;; A -> (B1 ... Bk) & nil in first(B1)...first(Bk) => - ;; nil in first(A) + ;; nil in first(A) (add-value! lhs '())) ;; A -> (B1 ... Bk C ...) & nil in first(B1)...first(Bk) ((member (car rhs) non-terminals) - (for-each + (for-each (lambda (sym) (if (not (null? sym)) - ;; & c in first(C) => c in first(A) + ;; & c in first(C) => c in first(A) (add-value! lhs sym) ;; e in first(C) -- continue to search down rhs (rhs-loop lhs (cdr rhs)))) (first (car rhs)))) (else ;; A -> (B1 ... Bk c ...) & nil in - ;; first(B1)...first(Bk) => c in first(A) + ;; first(B1)...first(Bk) => c in first(A) (add-value! lhs (car rhs)))))) (main-loop (lambda () (set! changed? #f) (for-each (lambda (production) - (rhs-loop + (rhs-loop (sllgen:production->lhs production) (sllgen:production->rhs production))) productions) @@ -794,11 +783,11 @@ (main-loop) table)))) (main-loop))))) - + (define sllgen:first-of-list (lambda (first-table non-terminals items) (let ((get-nonterminal - (lambda (item) + (lambda (item) (cond ((member item non-terminals) item) ((symbol? item) #f) @@ -828,7 +817,7 @@ these)))) (else (list (car items))))))) (loop items))))) - + (define sllgen:follow-table (lambda (start-symbol productions first-table) (let* ((non-terminals @@ -844,7 +833,7 @@ ;; follow(b) (closure-rules '()) (get-nonterminal - (lambda (item) + (lambda (item) (cond ((member item non-terminals) item) (else #f))))) @@ -862,7 +851,7 @@ (action (sllgen:production->action production))) (rhs-loop lhs - (append rhs ;; add back the goto as a nonterminal + (append rhs ;; add back the goto as a nonterminal (if (and (pair? action) (eq? (car action) 'goto)) (list (cadr action)) '()))) @@ -879,7 +868,7 @@ (first-of-rest (sllgen:first-of-list first-table non-terminals rest))) - (for-each + (for-each (lambda (sym) (if (not (null? sym)) ;; A -> (... B C ...) => first(C...) \subset follow(B) @@ -917,29 +906,29 @@ (init-loop productions) ; (sllgen:pretty-print closure-rules) (closure-loop))))) - - + + ;; **************************************************************** - + ;; gen-table.s - + ;; gen-table.s take list of productions, first and follow tables, ;; and generate parsing table - + ;; table ::= ((non-terminal (list-of-items action ...)....) ...) - + ;; the list of items is the first(rhs) for each production (or ;; follow(lhs) if the production is empty. We should probably check ;; to see that these are non-intersecting, but we probably won't on ;; this pass. - + ;; First thing to do: collect all the productions for a given ;; non-terminal. This gives data structure of the form - + ;; ((lhs production ...) ...) - + ;; We'll do this using updatable tables. - + (define sllgen:group-productions (lambda (productions) (let* ((non-terminals @@ -947,20 +936,19 @@ (table (sllgen:make-initial-table non-terminals))) (for-each (lambda (production) - (let - ((lhs (sllgen:production->lhs production))) + (let ((lhs (sllgen:production->lhs production))) (sllgen:add-value-to-table! table lhs production))) productions) table))) - + ;; this one uses the list structure of tables. [Watch out] - + (define sllgen:productions->parsing-table (lambda (productions first-table follow-table) (let ((non-terminals (sllgen:uniq (map sllgen:production->lhs productions))) (table (sllgen:group-productions productions))) - (map + (map (lambda (table-entry) (sllgen:make-parse-table-non-terminal-entry (car table-entry) @@ -970,11 +958,11 @@ production non-terminals first-table follow-table)) (unbox (cdr table-entry))))) table)))) - + (define sllgen:make-parse-table-non-terminal-entry (lambda (lhs entries) (cons lhs entries))) - + (define sllgen:make-parse-table-production-entry (lambda (production non-terminals first-table follow-table) (let* ((rhs (sllgen:production->rhs production)) @@ -994,12 +982,12 @@ non-terminals (sllgen:production->rhs production) (sllgen:production->action production)))))) - + (define sllgen:make-parse-table-rhs-entry (lambda (non-terminals rhs action) (let loop ((rhs rhs)) (cond - ((null? rhs) + ((null? rhs) ;; at end -- emit reduce action or emit-list action (if (symbol? action) ;; symbols become "reduce", @@ -1008,7 +996,7 @@ (list action))) ((sllgen:arbno-assv (car rhs)) => (lambda (pair) ; (cdr pair) is the count for - ; the arbno + ; the arbno (cons (list 'arbno (car rhs) (cdr pair)) (loop (cdr rhs))))) @@ -1025,19 +1013,19 @@ (error 'parser-generation "unknown rhs entry ~s" (car rhs))))))) - + ;; **************************************************************** - + ;; check-table.s - + ;; take a parse table and check for conflicts - + ;; table ::= ((non-terminal (list-of-items action ...)....) ...) - + (define sllgen:check-table (lambda (table) (for-each sllgen:check-productions table))) - + (define sllgen:check-productions (lambda (non-terminal-entry) (let ((non-terminal (car non-terminal-entry)) @@ -1064,40 +1052,40 @@ (car this-production)) ;; and check the others (loop other-productions))))))) - - - ;; **************************************************************** - + + + ;; **************************************************************** + ;; scan.scm - + ;; Scanner based on regexps and longest-match property - + ;; new version using proper lookahead in sllgen:scanner-inner-loop ;; Tue Dec 01 11:42:53 1998 - + ;; External syntax of scanner: - + ;; scanner ::= (init-state ...) ;; init-state ::= (classname (regexp ...) action-opcode) - ;; regexp = etester | (or regexp ...) | (arbno regexp) + ;; regexp = etester | (or regexp ...) | (arbno regexp) ;; | (concat regexp ...) ;; etester ::= string | LETTER | DIGIT | WHITESPACE | ANY | (NOT char) - + ;; top level stream transducer: - + (define sllgen:make-scanner-maker (lambda (init-states) (with-syntax ((start-states (sllgen:parse-scanner-spec init-states))) (syntax (lambda (input-stream) (sllgen:scanner-outer-loop 'start-states input-stream)))))) - + ;; Conversion of external to internal rep - + (define sllgen:parse-scanner-spec (lambda (init-states) (map sllgen:parse-init-state init-states))) - + (define sllgen:parse-init-state (lambda (init-state) (sllgen:check-syntax-init-state init-state) @@ -1107,19 +1095,19 @@ (sllgen:make-local-state (map sllgen:parse-regexp regexps) (cons opcode classname))))) - + (define sllgen:check-syntax-init-state (lambda (v) (or (and - (list? v) - (= (length v) 3) + (list? v) + (= (length v) 3) (symbol? (car v)) (list? (cadr v)) (symbol? (caddr v)) (member (caddr v) sllgen:action-preference-list)) (error 'scanner-generation "bad scanner item ~s" v)))) - + (define sllgen:parse-regexp (lambda (regexp) (cond @@ -1144,38 +1132,38 @@ (sllgen:make-tester-regexp regexp))) (else (error 'scanner-generation "bad regexp ~s" regexp)))) (else (error 'scanner-generation "bad regexp ~s" regexp))))) - + (define sllgen:string->regexp (lambda (string) (sllgen:make-concat-regexp (map sllgen:make-tester-regexp (map sllgen:make-char-tester (string->list string)))))) - + (define sllgen:symbol->regexp (lambda (sym) (if (member sym sllgen:tester-symbol-list) (sllgen:make-tester-regexp sym) (error 'scanner-generation "unknown tester ~s" sym)))) - + ;; localstate = regexp* x action - - (define sllgen:make-local-state + + (define sllgen:make-local-state (lambda (regexps action) (append regexps (list action)))) - - ;; regexps - ;; regexp = tester | (or regexp ...) | (arbno regexp) + + ;; regexps + ;; regexp = tester | (or regexp ...) | (arbno regexp) ;; | (concat regexp ...) - - + + ; (define-datatype regexp ; (tester-regexp sllgen:tester?) ; (or-regexp (list-of regexp?)) ; (arbno-regexp regexp?) ; (concat-regexp (list-of regexp?))) - + ;; (sllgen:select-variant obj selector1 receiver1 ... [err-thunk]) - + (define sllgen:select-variant (lambda (obj . alts) (let loop ((alts alts)) @@ -1186,8 +1174,8 @@ ((null? (cdr alts)) ((car alts))) (((car alts) obj) => (lambda (f) (f (cadr alts)))) (else (loop (cddr alts))))))) - - + + (define sllgen:unparse-regexp ; deals with regexps or actions (lambda (regexp) (if (sllgen:action? regexp) @@ -1204,19 +1192,19 @@ sllgen:or-regexp? (lambda (regexps) (cons 'or (map sllgen:unparse-regexp regexps))))))) - + ;; testers ;; tester ::= char | LETTER | DIGIT | ANY | WHITESPACE | (NOT char) - - ;; **************************************************************** - + + ;; **************************************************************** + ;; go through a grammar and generate the appropriate define-datatypes. - + ;; define-datatype syntax is: ;;(define-datatype Type-name Predicate-name ;; (Variant-name (Field-name Predicate-exp) ...) ...) - - + + (define sllgen:build-define-datatype-definitions (lambda (scanner-spec grammar) (let* ((scanner-datatypes-alist @@ -1233,7 +1221,7 @@ (sllgen:production->lhs production) (cons (sllgen:production->action production) - (sllgen:make-rhs-datatype-list + (sllgen:make-rhs-datatype-list (sllgen:production->rhs production) non-terminals scanner-datatypes-alist)))) @@ -1244,18 +1232,17 @@ (sllgen:make-datatype-definition non-terminal (sllgen:table-lookup datatype-table non-terminal))) non-terminals)))) - - + + (define sllgen:make-scanner-datatypes-alist (lambda (init-states) - (let - ((opcode-type-alist - '((make-symbol . symbol?) - (symbol . symbol?) - (make-string . string?) - (string . string?) - (make-number . number?) - (number . number?)))) + (let ((opcode-type-alist + '((make-symbol . symbol?) + (symbol . symbol?) + (make-string . string?) + (string . string?) + (make-number . number?) + (number . number?)))) (let loop ((init-states init-states)) (if (null? init-states) '() (let ((init-state (car init-states)) @@ -1264,9 +1251,9 @@ (type-pair (assq (sllgen:last init-state) opcode-type-alist))) (if (not type-pair) (loop init-states) - (cons (cons class (cdr type-pair)) + (cons (cons class (cdr type-pair)) (loop init-states)))))))))) - + (define sllgen:last (lambda (x) (and @@ -1275,12 +1262,12 @@ (if (null? (cdr x)) (car x) (sllgen:last (cdr x)))))) - + ;; rhs ::= (rhs-item ...) ;; ;; rhs-item ::= string | symbol | (ARBNO . rhs) | (SEPARATED-LIST rhs - ;; token) - + ;; token) + (define sllgen:make-rhs-datatype-list (lambda (rhs non-terminals scanner-datatypes-alist) (let ((report-error @@ -1305,38 +1292,38 @@ (report-error rhs-item "unknown symbol")))) ((sllgen:arbno? rhs-item) (append - (map + (map (lambda (x) (list 'list-of x)) (loop (sllgen:arbno->rhs rhs-item))) (loop rest))) ((sllgen:separated-list? rhs-item) (append - (map + (map (lambda (x) (list 'list-of x)) (loop (sllgen:separated-list->rhs rhs-item))) (loop rest))) ((string? rhs-item) (loop rest)) (else (report-error rhs-item "unrecognized item"))))))))) - + (define sllgen:non-terminal->tester-name (lambda (x) (string->symbol (string-append (symbol->string x) "?")))) - + ;; variants are now the same as constructors (define sllgen:variant->constructor-name (lambda (x) x)) - - + + (define sllgen:make-datatype-definition (lambda (non-terminal entries) (let ((tester-name (sllgen:non-terminal->tester-name non-terminal)) - (entries + (entries ;; reverse gets the entries in the same order as the productions (map sllgen:make-variant (reverse entries)))) `(define-datatype ,non-terminal ,tester-name . ,entries)))) - + (define sllgen:make-variant (lambda (entry) `(,(car entry) @@ -1370,7 +1357,7 @@ (sllgen:make-stream 'tag1 tree (lambda (fn eos) ; prevent evaluation for now - ((loop + ((loop ;; push the lookahead token back on the ;; stream iff it's there. (if (null? token) @@ -1384,7 +1371,7 @@ (let* ((char-stream (sllgen:string->stream string)) (token-stream (scanner char-stream)) (last-line (sllgen:char-stream->location char-stream))) - (parser + (parser (sllgen:stream-add-sentinel-via-thunk token-stream (lambda () @@ -1463,7 +1450,7 @@ ((skip) (error 'sllgen:cook-token "internal error: skip should have been handled earlier ~s" actions)) - ((make-symbol symbol) + ((make-symbol symbol) (sllgen:make-token classname (string->symbol (list->string (reverse buffer))) loc)) @@ -1489,7 +1476,7 @@ ; ((skip) (sllgen:error 'sllgen:cook-token ; "\nInternal error: skip should have been handled earlier ~s" ; actions)) -; ((make-symbol identifier) +; ((make-symbol identifier) ; (sllgen:make-token 'identifier ; (string->symbol (list->string (reverse buffer))) ; loc)) @@ -1509,7 +1496,7 @@ ;; k = (actions * newstates * char * stream) -> val (define sllgen:scanner-inner-loop - (lambda (local-states stream k) + (lambda (local-states stream k) (let ((actions '()) (newstates '()) (char '()) @@ -1585,7 +1572,7 @@ ;; (regexp1 (arbno regexp1) regexps action) (loop (append - (list + (list (cdr state) ; 0 occurrences (cons regexp1 state) ; >= 1 occurrences ) @@ -1596,7 +1583,7 @@ (lambda (sequents) ;; (printf "processing concat: sequents = ~s\n" sequents) (loop - (cons + (cons (append sequents (cdr state)) (cdr local-states))))))))))))) @@ -1604,38 +1591,38 @@ (define sllgen:scanner-outer-loop (lambda (start-states input-stream) ; -> (token stream), same as before - (let - ((states start-states) ; list of local-states - (buffer '()) ; characters accumulated so far - (success-buffer '()) ; characters for the last - ; candidate token (a sublist - ; of buffer) - (actions '()) ; actions we might perform on succ-buff + (let ((states start-states) ; list of local-states + (buffer '()) ; characters accumulated so far + (success-buffer '()) ; characters for the last + ; candidate token (a sublist + ; of buffer) + (actions '()) ; actions we might perform on succ-buff (stream input-stream) ) (letrec - ((process-stream + ((process-stream (lambda () - (sllgen:scanner-inner-loop states stream - (lambda (new-actions new-states char new-stream) - (when (not (null? new-actions)) - ;; ok, the current buffer is a candidate token - (begin - (set! success-buffer buffer) - ;; (printf "success-buffer =~s\n" success-buffer) - (set! actions new-actions)) - ;; otherwise leave success-buffer and actions alone - ) - (if (null? new-states) - ;; we are definitely at the end of this token - (process-buffer char new-stream) - ;; there might be more -- absorb another character and - ;; consider what to do next. - (begin - (set! buffer (cons char buffer)) - (set! stream new-stream) - (set! states new-states) - (process-stream))))))) + (sllgen:scanner-inner-loop + states stream + (lambda (new-actions new-states char new-stream) + (when (not (null? new-actions)) + ;; ok, the current buffer is a candidate token + (begin + (set! success-buffer buffer) + ;; (printf "success-buffer =~s\n" success-buffer) + (set! actions new-actions)) + ;; otherwise leave success-buffer and actions alone + ) + (if (null? new-states) + ;; we are definitely at the end of this token + (process-buffer char new-stream) + ;; there might be more -- absorb another character and + ;; consider what to do next. + (begin + (set! buffer (cons char buffer)) + (set! stream new-stream) + (set! states new-states) + (process-stream))))))) (process-buffer ; can't absorb any more chars, ; better make do with what we have. (lambda (char new-stream) @@ -1659,15 +1646,15 @@ (sllgen:char-stream-push-back! (car buffer) stream) (set! buffer (cdr buffer)) (push-back-loop)))) - ;; next, look at actions. + ;; next, look at actions. (cond ((null? actions) ;; no actions possible? Must be a mistake (error 'scanning "no actions found for ~s" (reverse buffer))) ((sllgen:is-all-skip? actions) - ;; If only action is SKIP, - ;; then discard buffer and start again. + ;; If only action is SKIP, + ;; then discard buffer and start again. (set! buffer '()) (set! success-buffer '()) (set! states start-states) ;! @@ -1705,9 +1692,9 @@ ;; (sllgen:stream-get! (sllgen:make-stream tag char stream) fcn eos-fcn) = (fcn char stream) -;; this is banged, because doing it on some streams may cause a side-effect. +;; this is banged, because doing it on some streams may cause a side-effect. (define sllgen:stream-get! - (lambda (str fcn eos-fcn) + (lambda (str fcn eos-fcn) (str fcn eos-fcn))) (define sllgen:empty-stream @@ -1734,7 +1721,7 @@ ; (define sllgen:stdin-char-stream ; (lambda (fcn eos-fcn) ; (let ((char (read-char))) -; (if (eof-object? char) +; (if (eof-object? char) ; (eos-fcn) ; (fcn char sllgen:stdin-char-stream))))) @@ -1755,7 +1742,7 @@ (define sllgen:stream-add-sentinel (lambda (stream sentinel) (lambda (fn eos) ; here's what to do on a get - (sllgen:stream-get! stream + (sllgen:stream-get! stream (lambda (val str) (fn val (sllgen:stream-add-sentinel str sentinel))) (lambda () @@ -1764,10 +1751,10 @@ (define sllgen:stream-add-sentinel-via-thunk (lambda (stream sentinel-fcn) (lambda (fn eos) ; here's what to do on a get - (sllgen:stream-get! stream + (sllgen:stream-get! stream (lambda (val str) (fn val (sllgen:stream-add-sentinel-via-thunk str sentinel-fcn))) - (lambda () + (lambda () ;; when the stream runs out, try this (let ((sentinel (sentinel-fcn))) ; (eopl:printf "~s\n" sentinel) @@ -1919,7 +1906,7 @@ ;; see tests.s for examples. -;; **************************************************************** +;; **************************************************************** ;; parse.s @@ -1928,8 +1915,8 @@ ;; parsing table is of following form: ;; table ::= ((non-terminal alternative ...) ...) -;; alternative ::= (list-of-items action ...) -;; action ::= (TERM symbol) | (NON-TERM symbol) | (GOTO symbol) +;; alternative ::= (list-of-items action ...) +;; action ::= (TERM symbol) | (NON-TERM symbol) | (GOTO symbol) ;; | (EMIT-LIST) | (REDUCE proc) ;; The token register can either contain an token or '() -- the latter @@ -2009,7 +1996,7 @@ (if (eq? (sllgen:token->class token) class) ;; ok, this matches, proceed, but don't get next token -- ;; after all, this might be the last one. - (loop next-action + (loop next-action (cons (sllgen:token->data token) buf) '() ; token register is now empty stream) @@ -2040,7 +2027,7 @@ (loop next-action (sllgen:unzip-buffer trees count buf) token stream))))) - + ((goto) (let ((non-terminal (cadr action))) (sllgen:find-production non-terminal parser buf token @@ -2063,7 +2050,7 @@ (define sllgen:unzip-buffer (lambda (trees n buf) (let ((ans (let consloop ((n n)) - (if (zero? n) + (if (zero? n) (list->mlist buf) (mcons '() (consloop (- n 1))))))) (let loop ((trees trees) diff --git a/collects/eopl/private/utils.rkt b/collects/eopl/private/utils.rkt index 1233bce3b3..9221e38607 100644 --- a/collects/eopl/private/utils.rkt +++ b/collects/eopl/private/utils.rkt @@ -1,17 +1,16 @@ -#lang racket +#lang racket/base - ;; Generative structure definitions: - (define-struct dt (pred-stx variants) #:mutable) - (define-struct vt (name-stx predicate-stx accessor-stx field-count) #:mutable) - - ;; Helper function: - (define (variant-assq name-stx variants) - (let loop ([l variants]) - (if (free-identifier=? name-stx - (vt-name-stx (car l))) - (car l) - (loop (cdr l))))) - - (provide (struct-out dt) - (struct-out vt) - variant-assq) +;; Generative structure definitions: +(define-struct dt (pred-stx variants) #:mutable) +(define-struct vt (name-stx predicate-stx accessor-stx field-count) #:mutable) + +;; Helper function: +(define (variant-assq name-stx variants) + (let loop ([l variants]) + (if (free-identifier=? name-stx (vt-name-stx (car l))) + (car l) + (loop (cdr l))))) + +(provide (struct-out dt) + (struct-out vt) + variant-assq)