diff --git a/collects/plai/plai-dynamic.ss b/collects/plai/plai-dynamic.ss new file mode 100644 index 0000000000..bd0aeb93c8 --- /dev/null +++ b/collects/plai/plai-dynamic.ss @@ -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)) diff --git a/collects/plai/plai-tool.ss b/collects/plai/plai-tool.ss index cc74f54cd8..6b06671e1f 100644 --- a/collects/plai/plai-tool.ss +++ b/collects/plai/plai-tool.ss @@ -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")))))) diff --git a/collects/plai/plai-void.ss b/collects/plai/plai-void.ss index 2e2d4275e3..7c798ed3ec 100644 --- a/collects/plai/plai-void.ss +++ b/collects/plai/plai-void.ss @@ -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) diff --git a/collects/plai/private/core-utils.ss b/collects/plai/private/core-utils.ss index 9020c62c46..d0dfcc21b0 100644 --- a/collects/plai/private/core-utils.ss +++ b/collects/plai/private/core-utils.ss @@ -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)) diff --git a/collects/plai/private/datatype-core.ss b/collects/plai/private/datatype-core.ss index 3ffc883962..f97615a451 100644 --- a/collects/plai/private/datatype-core.ss +++ b/collects/plai/private/datatype-core.ss @@ -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)