suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Some style things.

Browse Source
This commit is contained in:
Eli Barzilay 2013-02-23 02:07:46 -05:00
parent cec73f5652
commit 334e1cfdd9
6 changed files with 582 additions and 673 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

256
collects/eopl/datatype.rkt
View File

@ -1,64 +1,51 @@
;; NOTE: datatypes are currently transparent, for the sake of EoPL's ;; NOTE: datatypes are currently transparent, for the sake of EoPL's
;; use of `equal?' ;; 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 (define-syntax (define-datatype stx)
(lambda (stx)
(syntax-case stx () (syntax-case stx ()
[(_ name pred-name [(_ name pred-name
(variant-name (field-name field-pred) ...) (variant-name (field-name field-pred) ...)
...) ...)
(let ([variant-names (syntax->list (syntax (variant-name ...)))]) (let ([variant-names (syntax->list #'(variant-name ...))])
;; More syntax checks... ;; More syntax checks...
(unless (identifier? (syntax name)) (unless (identifier? #'name)
(raise-syntax-error #f (raise-syntax-error
"expected an identifier for the datatype name" #f "expected an identifier for the datatype name" stx #'name))
stx (syntax name))) (unless (identifier? #'pred-name)
(unless (identifier? (syntax pred-name)) (raise-syntax-error
(raise-syntax-error #f #f "expected an identifier for the predicate name" stx #'pred-name))
"expected an identifier for the predicate name" (for ([vt (in-list variant-names)]
stx (syntax pred-name))) [fields (in-list (syntax->list #'((field-name ...) ...)))])
(for-each (lambda (vt fields)
(unless (identifier? vt) (unless (identifier? vt)
(raise-syntax-error (raise-syntax-error
'cases 'cases "expected an identifier for the variant name" stx vt))
"expected an identifier for the variant name" (for ([field (in-list (syntax->list fields))])
stx vt))
(for-each (lambda (field)
(unless (identifier? field) (unless (identifier? field)
(raise-syntax-error (raise-syntax-error
'cases 'cases "expected an identifier for the field name" stx field))))
"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: ;; Count the fields for each variant:
(with-syntax ([(variant-field-count ...) (with-syntax ([(variant-field-count ...)
(map (lambda (n) (for/list ([x (in-list (syntax->list
(datum->syntax (quote-syntax here) n #f)) #'((field-name ...) ...)))])
(map length (datum->syntax (quote-syntax here)
(map (length (syntax->list x))
syntax->list #f))]
(syntax->list
(syntax ((field-name ...) ...))))))]
[(variant? ...) [(variant? ...)
(map (lambda (vn) (for/list ([vn (in-list variant-names)])
(datum->syntax (datum->syntax
vn vn
(string->uninterned-symbol (string->uninterned-symbol
(format "~a?" (syntax-e vn))))) (format "~a?" (syntax-e vn)))))]
variant-names)]
[(variant-accessor ...) [(variant-accessor ...)
(map (lambda (vn) (for/list ([vn (in-list variant-names)])
(datum->syntax (datum->syntax
vn vn
(string->uninterned-symbol (string->uninterned-symbol
(format "~a-accessor" (syntax-e vn))))) (format "~a-accessor" (syntax-e vn)))))]
variant-names)]
[(variant-mutator ...) [(variant-mutator ...)
(generate-temporaries variant-names)] (generate-temporaries variant-names)]
[(make-variant ...) [(make-variant ...)
@ -66,25 +53,22 @@
[(struct:variant ...) [(struct:variant ...)
(generate-temporaries variant-names)] (generate-temporaries variant-names)]
[(make-variant-name ...) [(make-variant-name ...)
(map (lambda (vn) (for/list ([vn (in-list variant-names)])
(datum->syntax (datum->syntax
vn vn
(string->symbol (string->symbol
(format "make-~a" (syntax-e vn))))) (format "make-~a" (syntax-e vn)))))])
variant-names)]) #'(begin
(syntax
(begin
(define-syntax name (define-syntax name
;; Note: we're back to the transformer environment, here. ;; Note: we're back to the transformer environment, here.
;; Also, this isn't a transformer function, so any direct ;; Also, this isn't a transformer function, so any direct
;; use of the name will trigger a syntax error. The name ;; use of the name will trigger a syntax error. The name
;; can be found by `syntax-local-value', though. ;; can be found by `syntax-local-value', though.
(let ([cert (syntax-local-certifier #t)]) (let ([cert (syntax-local-certifier #t)])
(make-dt (cert (syntax pred-name)) (make-dt (cert #'pred-name)
(list (list (make-vt (cert #'variant-name)
(make-vt (cert (syntax variant-name)) (cert #'variant?)
(cert (syntax variant?)) (cert #'variant-accessor)
(cert (syntax variant-accessor))
variant-field-count) variant-field-count)
...)))) ...))))
;; Bind the predicate and selector functions: ;; Bind the predicate and selector functions:
@ -107,128 +91,98 @@
(values (values
x? ;; The datatype predicate x? ;; The datatype predicate
;; Create the constructor functions: ;; Create the constructor functions:
(let ([vname (quote variant-name)]) (let* ([vname 'variant-name]
(let ([variant-name [variant-name
(lambda (field-name ...) (lambda (field-name ...)
(unless (field-pred field-name) (unless (field-pred field-name)
(error vname (error vname "bad value for ~a field: ~e"
"bad value for ~a field: ~e" 'field-name field-name))
(quote field-name)
field-name))
... ...
(make-variant field-name ...))]) (make-variant field-name ...))])
variant-name)) variant-name)
... ...
variant? ... variant? ...
variant-accessor ...)))) variant-accessor ...))))
;; Compatibility bindings ;; Compatibility bindings
(define-values (make-variant-name ...) (values variant-name ...))))))] (define-values (make-variant-name ...) (values variant-name ...)))))]
[(_ name pred-name variant ...) [(_ name pred-name variant ...)
;; Must be a bad variant... ;; Must be a bad variant...
(for-each (lambda (variant) (for ([variant (in-list (syntax->list #'(variant ...)))])
(syntax-case variant () (syntax-case variant ()
[(variant-name field ...) [(variant-name field ...)
(let ([name (syntax variant-name)]) (let ([name #'variant-name])
(unless (identifier? name) (unless (identifier? name)
(raise-syntax-error (raise-syntax-error
#f #f "expected an identifier for the variant name" stx name))
"expected an identifier for the variant name"
stx
name))
;; Must be a bad field: ;; Must be a bad field:
(for-each (lambda (field) (for ([field (in-list (syntax->list #'(field ...)))])
(syntax-case field () (syntax-case field ()
[(field-name field-pred) [(field-name field-pred)
(let ([name (syntax field-name)]) (let ([name #'field-name])
(unless (identifier? name) (unless (identifier? name)
(raise-syntax-error (raise-syntax-error
#f #f "expected an identifier for the field name" stx name)))]
"expected an identifier for the field name"
stx
name)))]
[_else [_else
(raise-syntax-error (raise-syntax-error
#f #f "expected a field name followed by a predicate expression, all in parentheses" stx field)])))]
"expected a field name followed by a predicate expression, all in parentheses"
stx
field)]))
(syntax->list (syntax (field ...)))))]
[_else [_else
(raise-syntax-error (raise-syntax-error
#f #f "expected a variant name followed by a sequence of field declarations, all in parentheses" stx variant)]))]
"expected a variant name followed by a sequence of field declarations, all in parentheses"
stx
variant)]))
(syntax->list (syntax (variant ...))))]
[(_ name) [(_ name)
(raise-syntax-error (raise-syntax-error
#f #f "missing predicate name and variant clauses" stx)]))
"missing predicate name and variant clauses"
stx)])))
(define-syntax cases (define-syntax (cases stx)
(lambda (stx)
(syntax-case stx () (syntax-case stx ()
[(_ datatype expr [(_ datatype expr
clause clause
...) ...)
;; Get datatype information: ;; Get datatype information:
(let ([dt (and (identifier? (syntax datatype)) (let ([dt (and (identifier? #'datatype)
(syntax-local-value (syntax datatype) (lambda () #f)))]) (syntax-local-value #'datatype (lambda () #f)))])
(unless (dt? dt) (unless (dt? dt)
(raise-syntax-error (raise-syntax-error 'cases "not a datatype name" stx #'datatype))
'cases
"not a datatype name"
stx
(syntax datatype)))
;; Parse clauses: ;; Parse clauses:
(let-values ([(vts field-idss bodys else-body) (define-values (vts field-idss bodys else-body)
(let loop ([clauses (syntax->list (syntax (clause ...)))][saw-cases null]) (let loop ([clauses (syntax->list #'(clause ...))]
(cond [saw-cases null])
[(null? clauses) (if (null? clauses)
(values null null null #f)] (values null null null #f)
[else
(let ([clause (car clauses)]) (let ([clause (car clauses)])
(syntax-case* clause () (syntax-case* clause ()
(lambda (a b) (lambda (a b)
(and (eq? (syntax-e b) 'else) (and (eq? (syntax-e b) 'else)
(not (identifier-binding b)))) (not (identifier-binding b))))
[(variant (field-id ...) body0 body1 ...) [(variant (field-id ...) body0 body1 ...)
(let* ([variant (syntax variant)] (let* ([variant #'variant]
[vt [vt (ormap (lambda (dtv)
(ormap (lambda (dtv) (define vt-name (vt-name-stx dtv))
(let ([vt-name (vt-name-stx dtv)])
(and (free-identifier=? variant vt-name) (and (free-identifier=? variant vt-name)
dtv))) dtv))
(dt-variants dt))] (dt-variants dt))]
[orig-variant (and vt (vt-name-stx vt))]) [orig-variant (and vt (vt-name-stx vt))])
(unless orig-variant (unless orig-variant
(raise-syntax-error (raise-syntax-error
#f #f
(format "not a variant of `~a'" (format "not a variant of `~a'"
(syntax->datum (syntax datatype))) (syntax->datum #'datatype))
stx stx
variant)) variant))
(let ([field-ids (syntax->list (syntax (field-id ...)))]) (let ([field-ids (syntax->list #'(field-id ...))])
(for-each (lambda (fid) (for ([fid (in-list field-ids)])
(unless (identifier? fid) (unless (identifier? fid)
(raise-syntax-error (raise-syntax-error
#f #f "expected an identifier for a field" stx fid)))
"expected an identifier for a field"
stx
fid)))
field-ids)
(let ([dtv (variant-assq variant (dt-variants dt))]) (let ([dtv (variant-assq variant (dt-variants dt))])
(unless (= (length field-ids) (unless (= (length field-ids) (vt-field-count dtv))
(vt-field-count dtv))
(raise-syntax-error (raise-syntax-error
#f #f
(format (format
"variant case `~a' for `~a' has wrong field count (expected ~a, found ~a)" "variant case `~a' for `~a' has wrong field count (expected ~a, found ~a)"
(syntax->datum variant) (syntax->datum variant)
(syntax->datum (syntax datatype)) (syntax->datum #'datatype)
(vt-field-count dtv) (vt-field-count dtv)
(length field-ids)) (length field-ids))
stx stx
@ -238,79 +192,58 @@
(let ([dup (check-duplicate-identifier field-ids)]) (let ([dup (check-duplicate-identifier field-ids)])
(when dup (when dup
(raise-syntax-error (raise-syntax-error
#f #f "duplicate field identifier" stx dup)))
"duplicate field identifier"
stx
dup)))
;; Check for redundant case: ;; Check for redundant case:
(when (memq orig-variant saw-cases) (when (memq orig-variant saw-cases)
(raise-syntax-error (raise-syntax-error #f "duplicate case" stx clause))
#f
"duplicate case"
stx
clause))
;; This clause is ok: ;; This clause is ok:
(let-values ([(vts idss bodys else) (let-values ([(vts idss bodys else)
(loop (cdr clauses) (cons orig-variant saw-cases))]) (loop (cdr clauses) (cons orig-variant saw-cases))])
(values (cons vt vts) (values (cons vt vts)
(cons field-ids idss) (cons field-ids idss)
(cons (syntax (begin body0 body1 ...)) bodys) (cons #'(begin body0 body1 ...) bodys)
else))))] else))))]
[(else body0 body1 ...) [(else body0 body1 ...)
(begin (begin
(unless (null? (cdr clauses)) (unless (null? (cdr clauses))
(raise-syntax-error (raise-syntax-error
#f #f "else clause must be last" stx clause))
"else clause must be last" (values null null null #'(begin body0 body1 ...)))]
stx [_else (raise-syntax-error #f "bad clause" stx clause)])))))
clause))
(values null null null (syntax (begin body0 body1 ...))))]
[_else (raise-syntax-error
#f
"bad clause"
stx
clause)]))]))])
;; Missing any variants? ;; Missing any variants?
(unless (or else-body (unless (or else-body (= (length vts) (length (dt-variants dt))))
(= (length vts) (length (dt-variants dt)))) (define here (map vt-name-stx vts))
(let* ([here (map vt-name-stx vts)] (define missing
[missing (let loop ([l (dt-variants dt)]) (let loop ([l (dt-variants dt)])
(cond (cond [(null? l) ""]
[(null? l) ""]
[(ormap (lambda (i) (free-identifier=? (vt-name-stx (car l)) i)) here) [(ormap (lambda (i) (free-identifier=? (vt-name-stx (car l)) i)) here)
(loop (cdr l))] (loop (cdr l))]
[else [else (format " ~a~a"
(format " ~a~a"
(syntax-e (vt-name-stx (car l))) (syntax-e (vt-name-stx (car l)))
(loop (cdr l)))]))]) (loop (cdr l)))])))
(raise-syntax-error (raise-syntax-error
#f #f
(format "missing cases for the following variants:~a" missing) (format "missing cases for the following variants:~a" missing)
stx))) stx))
;; Create the result: ;; Create the result:
(with-syntax ([pred (dt-pred-stx dt)] (with-syntax ([pred (dt-pred-stx dt)]
[(variant? ...) (map vt-predicate-stx vts)] [(variant? ...) (map vt-predicate-stx vts)]
[((field-extraction ...) ...) [((field-extraction ...) ...)
(map (lambda (vt) (for/list ([vt (in-list vts)])
(with-syntax ([accessor (vt-accessor-stx vt)]) (with-syntax ([accessor (vt-accessor-stx vt)])
(let loop ([n 0]) (let loop ([n 0])
(if (= n (vt-field-count vt)) (if (= n (vt-field-count vt))
null null
(cons (with-syntax ([n n]) (cons #`(accessor v #,n)
(syntax (accessor v n))) (loop (add1 n)))))))]
(loop (add1 n)))))))
vts)]
[((field-id ...) ...) field-idss] [((field-id ...) ...) field-idss]
[(body ...) bodys] [(body ...) bodys]
[else-body (or else-body [else-body (or else-body
(syntax #'(error 'cases "no variant case matched"))])
(error 'cases "no variant case matched")))]) #'(let ([v expr])
(syntax
(let ([v expr])
(if (not (pred v)) (if (not (pred v))
(error 'cases "not a ~a: ~s" (quote datatype) v) (error 'cases "not a ~a: ~s" (quote datatype) v)
(cond (cond
@ -318,25 +251,16 @@
(let ([field-id field-extraction] ...) (let ([field-id field-extraction] ...)
body)] body)]
... ...
[else else-body])))))))]))) [else else-body])))))]))
(define-syntax provide-datatype (define-syntax (provide-datatype stx)
(lambda (stx)
(syntax-case stx () (syntax-case stx ()
[(_ datatype) [(_ datatype)
(let ([dt (syntax-local-value (syntax datatype) (lambda () #f))]) (let ([dt (syntax-local-value #'datatype (lambda () #f))])
(unless (dt? dt) (unless (dt? dt)
(raise-syntax-error (raise-syntax-error #f "not a datatype name" stx #'datatype))
#f
"not a datatype name"
stx
(syntax datatype)))
(with-syntax ([pred (dt-pred-stx dt)] (with-syntax ([pred (dt-pred-stx dt)]
[(orig-variant ...) [(orig-variant ...) (map vt-name-stx (dt-variants dt))])
(map vt-name-stx (dt-variants dt))]) #'(provide datatype pred orig-variant ...)))]))
(syntax
(provide datatype
pred
orig-variant ...))))])))
(provide define-datatype cases provide-datatype) (provide define-datatype cases provide-datatype)

1
collects/eopl/info.rkt
View File

@ -3,4 +3,3 @@
(require string-constants) (require string-constants)
(define scribblings '(("eopl.scrbl" () (teaching -20)))) (define scribblings '(("eopl.scrbl" () (teaching -20))))

33
collects/eopl/private/sllgen.rkt
View File

@ -11,9 +11,7 @@
"../datatype.rkt" "../datatype.rkt"
"sllboth.rkt" "sllboth.rkt"
"slldef.rkt" "slldef.rkt"
(for-syntax racket/base (for-syntax racket/base "sllboth.rkt" "slldef.rkt"))
"sllboth.rkt"
"slldef.rkt"))
(provide sllgen:make-string-parser (provide sllgen:make-string-parser
@ -24,7 +22,8 @@
sllgen:show-define-datatypes sllgen:show-define-datatypes
sllgen:list-define-datatypes) sllgen:list-define-datatypes)
'(let ((time-stamp "Time-stamp: <2000-09-25 11:48:47 wand>")) #; ; this was originally quoted, probably intended as a comment
(let ((time-stamp "Time-stamp: <2000-09-25 11:48:47 wand>"))
(display (string-append (display (string-append
"sllgen.scm " "sllgen.scm "
(substring time-stamp 13 29) (substring time-stamp 13 29)
@ -113,7 +112,6 @@
scanner-spec)))) scanner-spec))))
(syntax (make-string-parser parser-maker scanner-maker))))) (syntax (make-string-parser parser-maker scanner-maker)))))
(define sllgen:make-stream-parser-maker (define sllgen:make-stream-parser-maker
(lambda (scanner-spec grammar srcstx) (lambda (scanner-spec grammar srcstx)
(with-syntax ((parser-maker (sllgen:make-parser-maker grammar srcstx)) (with-syntax ((parser-maker (sllgen:make-parser-maker grammar srcstx))
@ -124,7 +122,6 @@
scanner-spec)))) scanner-spec))))
(syntax (make-stream-parser parser-maker scanner-maker))))) (syntax (make-stream-parser parser-maker scanner-maker)))))
(define sllgen:make-stream-scanner-maker (define sllgen:make-stream-scanner-maker
(lambda (scanner-spec grammar srcstx) (lambda (scanner-spec grammar srcstx)
(sllgen:make-scanner-maker (sllgen:make-scanner-maker
@ -159,8 +156,6 @@
pretty-print pretty-print
'datatype-definitions)))))) 'datatype-definitions))))))
(define sllgen:list-define-datatypes-maker (define sllgen:list-define-datatypes-maker
(lambda (scanner-spec grammar srcstx) (lambda (scanner-spec grammar srcstx)
(with-syntax ((datatype-definitions (with-syntax ((datatype-definitions
@ -221,7 +216,6 @@
(sllgen:find-production 'start-symbol parse-table (sllgen:find-production 'start-symbol parse-table
'() '() token-stream k))))))) '() '() token-stream k)))))))
(define the-table 'ignored) (define the-table 'ignored)
(define sllgen:build-parse-table (define sllgen:build-parse-table
@ -321,8 +315,7 @@
(eq? (car rhs-item) 'separated-list) (eq? (car rhs-item) 'separated-list)
(> (length rhs-item) 2) (> (length rhs-item) 2)
(sllgen:rhs-check-syntax (cdr rhs-item)) (sllgen:rhs-check-syntax (cdr rhs-item))
(let (let ; ((last-item (car (last-pair rhs-item))))
; ((last-item (car (last-pair rhs-item))))
((last-item (sllgen:last rhs-item))) ((last-item (sllgen:last rhs-item)))
(or (symbol? last-item) (string? last-item)))))) (or (symbol? last-item) (string? last-item))))))
@ -360,7 +353,6 @@
(((car preds) obj) #t) (((car preds) obj) #t)
(else (loop (cdr preds)))))))) (else (loop (cdr preds))))))))
(define sllgen:grammar->productions (define sllgen:grammar->productions
(lambda (gram) gram)) ; nothing else now, but this (lambda (gram) gram)) ; nothing else now, but this
; might change ; might change
@ -368,8 +360,7 @@
(define sllgen:grammar->start-symbol (define sllgen:grammar->start-symbol
(lambda (gram) (lambda (gram)
(sllgen:production->lhs (sllgen:production->lhs
(car (car (sllgen:grammar->productions gram)))))
(sllgen:grammar->productions gram)))))
(define sllgen:make-production (define sllgen:make-production
(lambda (lhs rhs action) (lambda (lhs rhs action)
@ -452,7 +443,6 @@
;; table ::= ((symbol . list) ...) ;; table ::= ((symbol . list) ...)
(define sllgen:make-initial-table ; makes table with all entries (define sllgen:make-initial-table ; makes table with all entries
; initialized to empty ; initialized to empty
(lambda (symbols) (lambda (symbols)
@ -494,7 +484,6 @@
((eqv? a (car s)) (cdr s)) ((eqv? a (car s)) (cdr s))
(else (cons (car s) (sllgen:rember a (cdr s))))))) (else (cons (car s) (sllgen:rember a (cdr s)))))))
(define sllgen:gensym (define sllgen:gensym
(let ((n 0)) (let ((n 0))
(lambda (s) (lambda (s)
@ -947,8 +936,7 @@
(table (sllgen:make-initial-table non-terminals))) (table (sllgen:make-initial-table non-terminals)))
(for-each (for-each
(lambda (production) (lambda (production)
(let (let ((lhs (sllgen:production->lhs production)))
((lhs (sllgen:production->lhs production)))
(sllgen:add-value-to-table! table lhs production))) (sllgen:add-value-to-table! table lhs production)))
productions) productions)
table))) table)))
@ -1248,8 +1236,7 @@
(define sllgen:make-scanner-datatypes-alist (define sllgen:make-scanner-datatypes-alist
(lambda (init-states) (lambda (init-states)
(let (let ((opcode-type-alist
((opcode-type-alist
'((make-symbol . symbol?) '((make-symbol . symbol?)
(symbol . symbol?) (symbol . symbol?)
(make-string . string?) (make-string . string?)
@ -1604,8 +1591,7 @@
(define sllgen:scanner-outer-loop (define sllgen:scanner-outer-loop
(lambda (start-states input-stream) ; -> (token stream), same as before (lambda (start-states input-stream) ; -> (token stream), same as before
(let (let ((states start-states) ; list of local-states
((states start-states) ; list of local-states
(buffer '()) ; characters accumulated so far (buffer '()) ; characters accumulated so far
(success-buffer '()) ; characters for the last (success-buffer '()) ; characters for the last
; candidate token (a sublist ; candidate token (a sublist
@ -1616,7 +1602,8 @@
(letrec (letrec
((process-stream ((process-stream
(lambda () (lambda ()
(sllgen:scanner-inner-loop states stream (sllgen:scanner-inner-loop
states stream
(lambda (new-actions new-states char new-stream) (lambda (new-actions new-states char new-stream)
(when (not (null? new-actions)) (when (not (null? new-actions))
;; ok, the current buffer is a candidate token ;; ok, the current buffer is a candidate token

5
collects/eopl/private/utils.rkt
View File

@ -1,4 +1,4 @@
#lang racket #lang racket/base
;; Generative structure definitions: ;; Generative structure definitions:
(define-struct dt (pred-stx variants) #:mutable) (define-struct dt (pred-stx variants) #:mutable)
@ -7,8 +7,7 @@
;; Helper function: ;; Helper function:
(define (variant-assq name-stx variants) (define (variant-assq name-stx variants)
(let loop ([l variants]) (let loop ([l variants])
(if (free-identifier=? name-stx (if (free-identifier=? name-stx (vt-name-stx (car l)))
(vt-name-stx (car l)))
(car l) (car l)
(loop (cdr l))))) (loop (cdr l)))))