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

variant constructors bound to syntax

Browse Source 
svn: r875
This commit is contained in:
Matthew Flatt 2005-09-18 13:54:22 +00:00
parent dbd1261122
commit a840944371
5 changed files with 210 additions and 23 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

122
collects/plai/plai-dynamic.ss Normal file
View File

@ -0,0 +1,122 @@
;; Like PLAI advanced, but with dynamic scope.
;; No `let', `let*', or `letrec'.
;;`local' expects ;; all definitions to have the
;; form `(define id expr)'.
(module plai-dynamic mzscheme
(require (rename (lib "htdp-advanced.ss" "lang") plai-else else)
(rename (lib "htdp-advanced.ss" "lang") advanced-define define)
"private/datatype.ss"
"test-harness.ss")
;; This macro requires & provides bindings without
;; making them locally visible:
(define-syntax (provide-advanced stx)
#'(begin
(require (all-except (lib "htdp-advanced.ss" "lang")
#%top define local let let* letrec lambda))
(provide (all-from-except (lib "htdp-advanced.ss" "lang")
plai-else advanced-define))))
(provide-advanced)
(define-for-syntax (make-dynamic k)
(make-set!-transformer
(lambda (stx)
(syntax-case stx (set!)
[id
(identifier? #'id)
#'(lookup-dynamic 'id)]
[(set! id val)
#'(set-dynamic! 'id val)]
[(id expr ...)
#'((lookup-dynamic 'id) expr ...)]))))
(define-syntax to-dynamic
(syntax-rules ()
[(_ (id ...) expr)
(with-continuation-mark*
('id ...) ((box id) ...)
(let-syntax ([id (make-dynamic (quote-syntax id))]
...)
expr))]))
(define-syntax (dynamic-type-case stx)
(syntax-case stx ()
[(_ type expr
[id (param ...) body-expr]
...)
#'(advanced-type-case
type expr
[id (param ...)
(to-dynamic (param ...)
body-expr)] ...)]
[(_ . rest)
#'(advanced-type-case . rest)]))
(define-syntax (dynamic-define stx)
(syntax-case stx ()
[(_ (id arg ...) body-expr)
#'(advanced-define (id arg ...)
(to-dynamic
(arg ...)
body-expr))]
[(_ . rest)
#'(advanced-define . rest)]))
(define-syntax (dynamic-lambda stx)
(syntax-case stx ()
[(_ (id ...) expr)
#'(lambda (id ...)
(to-dynamic (id ...)
expr))]))
(define-syntax (dynamic-local stx)
(syntax-case stx (dynamic-define)
[(_ [(dynamic-define id val) ...] body-expr)
(andmap identifier? (syntax->list #'(id ...)))
#'(let [(id val) ...]
(to-dynamic (id ...)
body-expr))]))
(define-syntax (dynamic-top stx)
(syntax-case stx ()
[(_ . id)
(identifier? #'id)
#'(lookup-dynamic 'id)]))
(define (lookup-dynamic id)
(let ([v (continuation-mark-set-first #f id)])
(if v
(unbox v)
(namespace-variable-value id #f (lambda ()
(error 'eval
"no dynamic value for identifier: ~a"
id))))))
(define (set-dynamic! id val)
(let ([v (continuation-mark-set-first #f id)])
(if v
(set-box! v val)
(namespace-set-variable-value! id val))))
(define-syntax with-continuation-mark*
(syntax-rules ()
[(_ () () expr) expr]
[(_ (key . krest) (val . vrest) expr)
(with-continuation-mark key val
(with-continuation-mark* krest vrest expr))]))
(provide (rename dynamic-type-case type-case)
(rename dynamic-define define)
(rename dynamic-lambda lambda)
(rename dynamic-local local)
(rename dynamic-top #%top)
define-type
require provide provide-type
(all-from "test-harness.ss")
;; Hack to avoid certification bug :(
lookup-dynamic)
(define-type-case advanced-type-case plai-else))

11
collects/plai/plai-tool.ss
View File

@ -71,16 +71,13 @@ the default printing style shold be 'constructor instead of 'write
'((lib "plai-beginner.ss" "plai")
(lib "plai-intermediate.ss" "plai")
(lib "plai-advanced.ss" "plai")
(lib "plai-pretty-big.ss" "plai")
(lib "plai-void.ss" "plai"))
(lib "plai-pretty-big.ss" "plai"))
'("PLAI - Beginning Student"
"PLAI - Intermediate Student with lambda"
"PLAI - Advanced Student"
"PLAI - Pretty Big"
"PLAI - Void")
'((-500 0 0) (-500 0 1) (-500 0 3) (-500 0 4) (-500 0 5))
"PLAI - Pretty Big")
'((-500 0 0) (-500 0 1) (-500 0 3) (-500 0 4))
'("PLAI: beginning students"
"PLAI: beginner plus lexical scope and higher-order functions"
"PLAI: intermediate plus lambda and mutation"
"PLAI: PLT Pretty Big plus define-type"
"PLAI: advanced without function arguments, lambda, or local"))))))
"PLAI: PLT Pretty Big plus define-type"))))))

6
collects/plai/plai-void.ss
View File

@ -1,3 +1,9 @@
;; Like PLAI Advanced, but all functions must accept one
;; argument, and the result is always changed to void.
;; To enforce void returns, tail call are broken, currently.
;; No `lambda', `local', `let', `let*', or `letrec'.
(module plai-void mzscheme
(require (rename (lib "htdp-advanced.ss" "lang") plai-else else)
(rename (lib "htdp-advanced.ss" "lang") advanced-define define)

41
collects/plai/private/core-utils.ss
View File

@ -1,6 +1,7 @@
(module core-utils mzscheme
(require-for-template mzscheme)
(define-values (struct:dt make-dt dt? dt-selector dt-accessor)
(make-struct-type 'dt #f 3 0 #f null (current-inspector)
(lambda (dt stx)
@ -13,6 +14,43 @@
(define dt-kind (make-struct-field-accessor dt-selector 2 'kind))
(define-struct vt (name-stx predicate-stx accessor-stx selector-stxes field-count))
(define-values (struct:dtvt make-dtvt dtvt? dtvt-selector dtvt-accessor)
(make-struct-type 'dtvt #f 3 0 #f null (current-inspector)
(lambda (dtvt stx)
(syntax-case stx (set!)
[(set! id v)
(raise-syntax-error
#f
"cannot assign to a variant name"
stx
#'id)]
[(id . args)
(let ([v (syntax-local-value (dtvt-orig-id dtvt)
(lambda () #f))])
(if (and (procedure? v)
(procedure-arity-includes? v 1))
;; Apply macro binding for orig id to this id:
(v stx)
;; Orig id is not bound to a macro:
(datum->syntax-object
stx
(cons (dtvt-orig-id dtvt)
(syntax args))
stx)))]
[else
(let ([v (syntax-local-value (dtvt-orig-id dtvt)
(lambda () #f))])
(if (and (procedure? v)
(procedure-arity-includes? v 1))
;; Apply macro binding for orig id to this id:
(v stx)
;; Orig id is not bound to a macro:
(dtvt-orig-id dtvt)))]))))
(define dtvt-dt (make-struct-field-accessor dtvt-selector 0 'dt))
(define dtvt-vt (make-struct-field-accessor dtvt-selector 1 'vt))
(define dtvt-orig-id (make-struct-field-accessor dtvt-selector 2 'orig-id))
;; Helper function:
(define (variant-assq name-stx variants)
@ -24,4 +62,5 @@
(provide make-dt dt? dt-pred-stx dt-variants
(struct vt (name-stx predicate-stx accessor-stx selector-stxes field-count))
make-dtvt dtvt? dtvt-dt dtvt-vt
variant-assq))

53
collects/plai/private/datatype-core.ss
View File

@ -52,10 +52,15 @@
(flat-contract c))))
;; Syntax:
;; (define-datatype-core orig-form d-v (option ...) name (alpha ...) pred-name variant ...)
;; (define-datatype-core orig-form (option ...) d-v name (alpha ...) pred-name variant ...)
;; where the syntax is like `define-datatype' starting with `pred-name'.
;;
;; The `orig-stx' part is used for syntax-error reporting.
;; The `d-v' is used in place of `define-values' to binding procedures.
;; The `d-v' is used in place of `define-values' to bind procedures. Beware
;; that variant-constructor procedures are bound as syntax and an different
;; name is bound to the actual procedure; if this "actual" binding itself
;; turns out to be a macro, then uses of the constructor name are expanded
;; by directly calling the macro from the "actual" binding
;; Each `alpha' is a parameter to the contract expressions of each variant field;
;; using `x-of' for variant `x' allows the parameter contracts to be supplied,
;; while using `x' directly instantiates each parameter as `any/c'.
@ -69,6 +74,16 @@
;; requires define-selectors
;; define-compatibility: include `make-x' for each variant `x'
;; (kind "str") : uses "str" to name the result, either "type" or "datatype"
;;
;; Internals:
;; The `name' is bound as syntax to a dt record, which supplies an id
;; for the datatype's predicate, and also lists the ;; datatype's variants
;; through vt records.
;; Each variant constructor name is bound as syntax to a dtvt record,
;; which gives the variant's vt record as well as its datatype's dt
;; record.
;; (See "core-utils.ss" for the dt, vt, and dtvt records.)
;;
(define-syntax define-datatype-core
(lambda (stx)
(syntax-case stx ()
@ -109,7 +124,9 @@
(map (lambda (n)
(datum->syntax-object (quote-syntax here) n #f))
(map length field-nameses))]
[(variant-name/no-contract ...)
[(orig-variant-name ...)
(generate-dt-temporaries variant-names)]
[(variant-name/no-contract ...)
(generate-dt-temporaries variant-names)]
[(variant-of ...)
(map (lambda (variant-name)
@ -186,29 +203,35 @@
"datatype")])
(quasisyntax
(begin
(define-syntax name
(define-syntaxes (name variant-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)])
(make-set!-transformer
(make-dt (cert (syntax pred-name))
(list
(make-vt (cert (quote-syntax variant-name))
(cert (quote-syntax variant?))
(cert (quote-syntax variant-accessor))
(list (quote-syntax selector-name) ...)
variant-field-count)
...)
datatype-str))))
(let-values ([(variant-name ...)
(values
(make-vt (cert (quote-syntax variant-name))
(cert (quote-syntax variant?))
(cert (quote-syntax variant-accessor))
(list (quote-syntax selector-name) ...)
variant-field-count)
...)])
(let ([dt (make-dt (cert (syntax pred-name))
(list variant-name ...)
datatype-str)])
(values
(make-set!-transformer dt)
(make-set!-transformer
(make-dtvt dt variant-name (quote-syntax orig-variant-name)))
...)))))
;; Bind the predicate and selector functions:
(define-proc-values (pred-name
variant-name/no-contract ...
variant? ...
variant-accessor ...
selector-name ... ...
variant-name ...)
orig-variant-name ...)
;; 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)