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

576
collects/eopl/datatype.rkt
View File

@ -1,342 +1,266 @@
;; 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 #'(variant-name ...))])
(let ([variant-names (syntax->list (syntax (variant-name ...)))]) ;; More syntax checks...
;; More syntax checks... (unless (identifier? #'name)
(unless (identifier? (syntax name)) (raise-syntax-error
(raise-syntax-error #f #f "expected an identifier for the datatype name" stx #'name))
"expected an identifier for the datatype name" (unless (identifier? #'pred-name)
stx (syntax name))) (raise-syntax-error
(unless (identifier? (syntax pred-name)) #f "expected an identifier for the predicate name" stx #'pred-name))
(raise-syntax-error #f (for ([vt (in-list variant-names)]
"expected an identifier for the predicate name" [fields (in-list (syntax->list #'((field-name ...) ...)))])
stx (syntax pred-name))) (unless (identifier? vt)
(for-each (lambda (vt fields) (raise-syntax-error
(unless (identifier? vt) 'cases "expected an identifier for the variant name" stx vt))
(raise-syntax-error (for ([field (in-list (syntax->list fields))])
'cases (unless (identifier? field)
"expected an identifier for the variant name" (raise-syntax-error
stx vt)) 'cases "expected an identifier for the field name" stx field))))
(for-each (lambda (field) ;; Count the fields for each variant:
(unless (identifier? field) (with-syntax ([(variant-field-count ...)
(raise-syntax-error (for/list ([x (in-list (syntax->list
'cases #'((field-name ...) ...)))])
"expected an identifier for the field name" (datum->syntax (quote-syntax here)
stx field))) (length (syntax->list x))
(syntax->list fields))) #f))]
variant-names [(variant? ...)
(syntax->list (syntax ((field-name ...) ...)))) (for/list ([vn (in-list variant-names)])
;; Count the fields for each variant: (datum->syntax
(with-syntax ([(variant-field-count ...) vn
(map (lambda (n) (string->uninterned-symbol
(datum->syntax (quote-syntax here) n #f)) (format "~a?" (syntax-e vn)))))]
(map length [(variant-accessor ...)
(map (for/list ([vn (in-list variant-names)])
syntax->list (datum->syntax
(syntax->list vn
(syntax ((field-name ...) ...))))))] (string->uninterned-symbol
[(variant? ...) (format "~a-accessor" (syntax-e vn)))))]
(map (lambda (vn) [(variant-mutator ...)
(datum->syntax (generate-temporaries variant-names)]
vn [(make-variant ...)
(string->uninterned-symbol (generate-temporaries variant-names)]
(format "~a?" (syntax-e vn))))) [(struct:variant ...)
variant-names)] (generate-temporaries variant-names)]
[(variant-accessor ...) [(make-variant-name ...)
(map (lambda (vn) (for/list ([vn (in-list variant-names)])
(datum->syntax (datum->syntax
vn vn
(string->uninterned-symbol (string->symbol
(format "~a-accessor" (syntax-e vn))))) (format "make-~a" (syntax-e vn)))))])
variant-names)] #'(begin
[(variant-mutator ...) (define-syntax name
(generate-temporaries variant-names)] ;; Note: we're back to the transformer environment, here.
[(make-variant ...) ;; Also, this isn't a transformer function, so any direct
(generate-temporaries variant-names)] ;; use of the name will trigger a syntax error. The name
[(struct:variant ...) ;; can be found by `syntax-local-value', though.
(generate-temporaries variant-names)] (let ([cert (syntax-local-certifier #t)])
[(make-variant-name ...) (make-dt (cert #'pred-name)
(map (lambda (vn) (list (make-vt (cert #'variant-name)
(datum->syntax (cert #'variant?)
vn (cert #'variant-accessor)
(string->symbol variant-field-count)
(format "make-~a" (syntax-e vn))))) ...))))
variant-names)]) ;; Bind the predicate and selector functions:
(syntax (define-values (pred-name
(begin variant-name ...
(define-syntax name variant? ...
;; Note: we're back to the transformer environment, here. variant-accessor ...)
;; Also, this isn't a transformer function, so any direct ;; Create a new structure for the datatype (using the
;; use of the name will trigger a syntax error. The name ;; datatype name in `struct', so it prints nicely).
;; can be found by `syntax-local-value', though. (let-values ([(struct:x make-x x? acc mut)
(let ([cert (syntax-local-certifier #t)]) (make-struct-type 'name #f 0 0 #f null (make-inspector))])
(make-dt (cert (syntax pred-name)) (let-values ([(struct:variant make-variant variant?
(list variant-accessor variant-mutator)
(make-vt (cert (syntax variant-name)) (make-struct-type 'variant-name struct:x variant-field-count 0
(cert (syntax variant?)) #f
(cert (syntax variant-accessor)) null
variant-field-count) (make-inspector))]
...)))) ...)
;; Bind the predicate and selector functions: ;; User-available functions:
(define-values (pred-name (values
variant-name ... x? ;; The datatype predicate
variant? ... ;; Create the constructor functions:
variant-accessor ...) (let* ([vname 'variant-name]
;; Create a new structure for the datatype (using the [variant-name
;; datatype name in `struct', so it prints nicely). (lambda (field-name ...)
(let-values ([(struct:x make-x x? acc mut) (unless (field-pred field-name)
(make-struct-type 'name #f 0 0 #f null (make-inspector))]) (error vname "bad value for ~a field: ~e"
(let-values ([(struct:variant make-variant variant? 'field-name field-name))
variant-accessor variant-mutator) ...
(make-struct-type 'variant-name struct:x variant-field-count 0 (make-variant field-name ...))])
#f variant-name)
null ...
(make-inspector))] variant? ...
...) variant-accessor ...))))
;; User-available functions: ;; Compatibility bindings
(values (define-values (make-variant-name ...) (values variant-name ...)))))]
x? ;; The datatype predicate [(_ name pred-name variant ...)
;; Create the constructor functions: ;; Must be a bad variant...
(let ([vname (quote variant-name)]) (for ([variant (in-list (syntax->list #'(variant ...)))])
(let ([variant-name (syntax-case variant ()
(lambda (field-name ...) [(variant-name field ...)
(unless (field-pred field-name) (let ([name #'variant-name])
(error vname (unless (identifier? name)
"bad value for ~a field: ~e" (raise-syntax-error
(quote field-name) #f "expected an identifier for the variant name" stx name))
field-name)) ;; Must be a bad field:
... (for ([field (in-list (syntax->list #'(field ...)))])
(make-variant field-name ...))]) (syntax-case field ()
variant-name)) [(field-name field-pred)
... (let ([name #'field-name])
variant? ... (unless (identifier? name)
variant-accessor ...)))) (raise-syntax-error
;; Compatibility bindings #f "expected an identifier for the field name" stx name)))]
(define-values (make-variant-name ...) (values variant-name ...))))))] [_else
[(_ name pred-name variant ...) (raise-syntax-error
;; Must be a bad variant... #f "expected a field name followed by a predicate expression, all in parentheses" stx field)])))]
(for-each (lambda (variant) [_else
(syntax-case variant () (raise-syntax-error
[(variant-name field ...) #f "expected a variant name followed by a sequence of field declarations, all in parentheses" stx variant)]))]
(let ([name (syntax variant-name)]) [(_ name)
(unless (identifier? name) (raise-syntax-error
(raise-syntax-error #f "missing predicate name and variant clauses" stx)]))
#f
"expected an identifier for the variant name" (define-syntax (cases stx)
stx (syntax-case stx ()
name)) [(_ datatype expr
;; Must be a bad field: clause
(for-each (lambda (field) ...)
(syntax-case field () ;; Get datatype information:
[(field-name field-pred) (let ([dt (and (identifier? #'datatype)
(let ([name (syntax field-name)]) (syntax-local-value #'datatype (lambda () #f)))])
(unless (identifier? name) (unless (dt? dt)
(raise-syntax-error (raise-syntax-error 'cases "not a datatype name" stx #'datatype))
#f
"expected an identifier for the field name" ;; Parse clauses:
stx (define-values (vts field-idss bodys else-body)
name)))] (let loop ([clauses (syntax->list #'(clause ...))]
[_else [saw-cases null])
(raise-syntax-error (if (null? clauses)
#f (values null null null #f)
"expected a field name followed by a predicate expression, all in parentheses" (let ([clause (car clauses)])
stx (syntax-case* clause ()
field)])) (lambda (a b)
(syntax->list (syntax (field ...)))))] (and (eq? (syntax-e b) 'else)
[_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 (raise-syntax-error
#f #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 stx
variant)])) variant))
(syntax->list (syntax (variant ...))))]
[(_ name)
(raise-syntax-error
#f
"missing predicate name and variant clauses"
stx)])))
(define-syntax cases (let ([field-ids (syntax->list #'(field-id ...))])
(lambda (stx) (for ([fid (in-list field-ids)])
(syntax-case stx () (unless (identifier? fid)
[(_ datatype expr (raise-syntax-error
clause #f "expected an identifier for a field" stx fid)))
...) (let ([dtv (variant-assq variant (dt-variants dt))])
;; Get datatype information: (unless (= (length field-ids) (vt-field-count dtv))
(let ([dt (and (identifier? (syntax datatype)) (raise-syntax-error
(syntax-local-value (syntax datatype) (lambda () #f)))]) #f
(unless (dt? dt) (format
(raise-syntax-error "variant case `~a' for `~a' has wrong field count (expected ~a, found ~a)"
'cases (syntax->datum variant)
"not a datatype name" (syntax->datum #'datatype)
stx (vt-field-count dtv)
(syntax datatype))) (length field-ids))
stx
clause)))
;; Parse clauses: ;; Check for duplicate local field ids:
(let-values ([(vts field-idss bodys else-body) (let ([dup (check-duplicate-identifier field-ids)])
(let loop ([clauses (syntax->list (syntax (clause ...)))][saw-cases null]) (when dup
(cond (raise-syntax-error
[(null? clauses) #f "duplicate field identifier" stx dup)))
(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))
(let ([field-ids (syntax->list (syntax (field-id ...)))]) ;; Check for redundant case:
(for-each (lambda (fid) (when (memq orig-variant saw-cases)
(unless (identifier? fid) (raise-syntax-error #f "duplicate case" stx clause))
(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 duplicate local field ids: ;; This clause is ok:
(let ([dup (check-duplicate-identifier field-ids)]) (let-values ([(vts idss bodys else)
(when dup (loop (cdr clauses) (cons orig-variant saw-cases))])
(raise-syntax-error (values (cons vt vts)
#f (cons field-ids idss)
"duplicate field identifier" (cons #'(begin body0 body1 ...) bodys)
stx else))))]
dup))) [(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: ;; Create the result:
(when (memq orig-variant saw-cases) (with-syntax ([pred (dt-pred-stx dt)]
(raise-syntax-error [(variant? ...) (map vt-predicate-stx vts)]
#f [((field-extraction ...) ...)
"duplicate case" (for/list ([vt (in-list vts)])
stx (with-syntax ([accessor (vt-accessor-stx vt)])
clause)) (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: (define-syntax (provide-datatype stx)
(let-values ([(vts idss bodys else) (syntax-case stx ()
(loop (cdr clauses) (cons orig-variant saw-cases))]) [(_ datatype)
(values (cons vt vts) (let ([dt (syntax-local-value #'datatype (lambda () #f))])
(cons field-ids idss) (unless (dt? dt)
(cons (syntax (begin body0 body1 ...)) bodys) (raise-syntax-error #f "not a datatype name" stx #'datatype))
else))))] (with-syntax ([pred (dt-pred-stx dt)]
[(else body0 body1 ...) [(orig-variant ...) (map vt-name-stx (dt-variants dt))])
(begin #'(provide datatype pred orig-variant ...)))]))
(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 ...))))])))
(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))))

56
collects/eopl/private/sllboth.rkt
View File

@ -5,18 +5,18 @@
;; S-expression. ;; S-expression.
(provide sllgen:action-preference-list (provide sllgen:action-preference-list
sllgen:action? sllgen:action?
sllgen:make-tester-regexp sllgen:make-tester-regexp
sllgen:make-or-regexp sllgen:make-or-regexp
sllgen:make-arbno-regexp sllgen:make-arbno-regexp
sllgen:make-concat-regexp sllgen:make-concat-regexp
sllgen:tester-regexp? sllgen:tester-regexp?
sllgen:or-regexp? sllgen:or-regexp?
sllgen:arbno-regexp? sllgen:arbno-regexp?
sllgen:concat-regexp? sllgen:concat-regexp?
sllgen:tester-symbol-list sllgen:tester-symbol-list
sllgen:make-char-tester sllgen:make-char-tester
sllgen:tester?) sllgen:tester?)
(define sllgen:action-preference-list (define sllgen:action-preference-list
'(string make-string symbol make-symbol number make-number skip)) '(string make-string symbol make-symbol number make-number skip))
@ -29,42 +29,42 @@
(symbol? (cdr action))))) (symbol? (cdr action)))))
(define sllgen:make-tester-regexp (lambda (x) x)) (define sllgen:make-tester-regexp (lambda (x) x))
(define sllgen:make-or-regexp (lambda (res) (cons 'or res))) (define sllgen:make-or-regexp (lambda (res) (cons 'or res)))
(define sllgen:make-arbno-regexp (lambda (re) (list 'arbno re))) (define sllgen:make-arbno-regexp (lambda (re) (list 'arbno re)))
(define sllgen:make-concat-regexp (lambda (rs) (cons 'concat rs))) (define sllgen:make-concat-regexp (lambda (rs) (cons 'concat rs)))
(define sllgen:tester-regexp? (define sllgen:tester-regexp?
(lambda (x) (lambda (x)
(and (sllgen:tester? x) (lambda (f) (f x))))) (and (sllgen:tester? x) (lambda (f) (f x)))))
(define sllgen:or-regexp? (define sllgen:or-regexp?
(lambda (x) (lambda (x)
(and (eq? (car x) 'or) (and (eq? (car x) 'or)
(lambda (f) (f (cdr x)))))) (lambda (f) (f (cdr x))))))
(define sllgen:arbno-regexp? (define sllgen:arbno-regexp?
(lambda (x) (lambda (x)
(and (eq? (car x) 'arbno) (and (eq? (car x) 'arbno)
(lambda (f) (f (cadr x)))))) (lambda (f) (f (cadr x))))))
(define sllgen:concat-regexp? (define sllgen:concat-regexp?
(lambda (x) (lambda (x)
(and (eq? (car x) 'concat) (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:tester-symbol-list '(letter digit any whitespace))
(define sllgen:make-char-tester (define sllgen:make-char-tester
(lambda (char) (lambda (char)
(and (or (char? char) (and (or (char? char)
(error 'scanner-generation "illegal character ~s" char)) (error 'scanner-generation "illegal character ~s" char))
char))) char)))
(define sllgen:tester? (define sllgen:tester?
(lambda (v) (lambda (v)
(or (char? v) (or (char? v)
(member v sllgen:tester-symbol-list) (member v sllgen:tester-symbol-list)
(and (pair? v) (and (pair? v)
(eq? (car v) 'not) (eq? (car v) 'not)
(pair? (cdr v)) (pair? (cdr v))
(char? (cadr v)))))) (char? (cadr v))))))

6
collects/eopl/private/slldef.rkt
View File

@ -1,4 +1,4 @@
#lang racket #lang racket
;; A compile-time table shared by eopl and sllgen: ;; A compile-time table shared by eopl and sllgen:
(define sllgen-def (make-hasheq)) (define sllgen-def (make-hasheq))
(provide sllgen-def) (provide sllgen-def)

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

File diff suppressed because it is too large Load Diff

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

@ -1,17 +1,16 @@
#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)
(define-struct vt (name-stx predicate-stx accessor-stx field-count) #:mutable) (define-struct vt (name-stx predicate-stx accessor-stx field-count) #:mutable)
;; 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)))))
(provide (struct-out dt)
(provide (struct-out dt) (struct-out vt)
(struct-out vt) variant-assq)
variant-assq)