diff --git a/collects/plai/plai-tool.ss b/collects/plai/plai-tool.ss index aa4889d570..cc74f54cd8 100644 --- a/collects/plai/plai-tool.ss +++ b/collects/plai/plai-tool.ss @@ -71,13 +71,16 @@ 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-pretty-big.ss" "plai") + (lib "plai-void.ss" "plai")) '("PLAI - Beginning Student" "PLAI - Intermediate Student with lambda" "PLAI - Advanced Student" - "PLAI - Pretty Big") - '((-500 0 0) (-500 0 1) (-500 0 3) (-500 0 4)) + "PLAI - Pretty Big" + "PLAI - Void") + '((-500 0 0) (-500 0 1) (-500 0 3) (-500 0 4) (-500 0 5)) '("PLAI: beginning students" "PLAI: beginner plus lexical scope and higher-order functions" "PLAI: intermediate plus lambda and mutation" - "PLAI: professional plt plus define-datatype")))))) + "PLAI: PLT Pretty Big plus define-type" + "PLAI: advanced without function arguments, lambda, or local")))))) diff --git a/collects/plai/plai-void.ss b/collects/plai/plai-void.ss new file mode 100644 index 0000000000..2e2d4275e3 --- /dev/null +++ b/collects/plai/plai-void.ss @@ -0,0 +1,40 @@ +(module plai-void 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-void stx) + #'(begin + (require (all-except (lib "htdp-advanced.ss" "lang") + lambda define local let let* letrec)) + (provide (all-from-except (lib "htdp-advanced.ss" "lang") + plai-else advanced-define)))) + (provide-void) + + (provide (rename void-define define) + (rename void-type-case type-case) + define-type + require provide provide-type + (all-from "test-harness.ss")) + + (define-syntax (void-define stx) + (syntax-case stx () + [(_ id v) + (identifier? #'id) + #'(advanced-define id v)] + [(_ (id) body) + (identifier? #'id) + #'(advanced-define (id) (begin body (void)))] + [(_ (id x0 x ...) . rest) + (andmap identifier? (syntax->list #'(id x0 x ...))) + (raise-syntax-error + #f + "defined functions must accept no arguments in this language" + stx)] + [(_ . rest) + #'(advanced-define . rest)])) + + (define-type-case void-type-case plai-else)) diff --git a/collects/plai/private/datatype-core.ss b/collects/plai/private/datatype-core.ss index 47c3d27247..78502d6c32 100644 --- a/collects/plai/private/datatype-core.ss +++ b/collects/plai/private/datatype-core.ss @@ -334,7 +334,7 @@ (define-syntax cases-core (lambda (stx) (syntax-case stx () - [(_ orig-stx datatype-str cases-else + [(_ orig-stx datatype-str case-begin cases-else datatype expr clause ...) @@ -420,7 +420,9 @@ (loop (cdr clauses) (cons orig-variant saw-cases))]) (values (cons vt vts) (cons field-ids idss) - (cons (syntax (begin body0 body1 ...)) bodys) + (cons (with-syntax ([clause clause]) + (syntax (case-begin orig-stx clause body0 body1 ...))) + bodys) else))))] [(else body0 body1 ...) (begin diff --git a/collects/plai/private/datatype.ss b/collects/plai/private/datatype.ss index 191b950dd3..7266a3643e 100644 --- a/collects/plai/private/datatype.ss +++ b/collects/plai/private/datatype.ss @@ -43,12 +43,23 @@ "expected an identifier for the type name" stx)])) + (define-syntax (case-begin stx) + (syntax-case stx () + [(_ orig-stx orig-clause expr) #'expr] + [(_ orig-stx orig-clause expr0 expr ...) + (raise-syntax-error + #f + (format "expected only one result expression, found ~a" + (add1 (length (syntax->list #'(expr ...))))) + #'orig-stx + #'orig-clause)])) + (define-syntax define-type-case (syntax-rules () [(_ type-case else) (define-syntax (type-case stx) (syntax-case stx () - [(_ . rest) #`(cases-core #,stx "type" else . rest)]))])) + [(_ . rest) #`(cases-core #,stx "type" case-begin else . rest)]))])) (define-syntax (provide-type stx) (syntax-case stx ()