diff --git a/collects/eopl/datatype.ss b/collects/eopl/datatype.ss index 21fc21a436..85212c248e 100644 --- a/collects/eopl/datatype.ss +++ b/collects/eopl/datatype.ss @@ -192,7 +192,9 @@ (values null null null #f)] [else (let ([clause (car clauses)]) - (syntax-case clause (else) + (syntax-case* clause (else) (lambda (a b) + (and (eq? (syntax-e b) 'else) + (not (identifier-binding b)))) [(variant (field-id ...) body0 body1 ...) (let* ([variant (syntax variant)] [vt diff --git a/collects/eopl/eopl-tool.ss b/collects/eopl/eopl-tool.ss index 62c88ef714..80bae05834 100644 --- a/collects/eopl/eopl-tool.ss +++ b/collects/eopl/eopl-tool.ss @@ -48,6 +48,7 @@ wraps the load of the module.) (define/override (use-namespace-require/copy?) #t) (define/override (on-execute settings run-in-user-thread) (super on-execute settings run-in-user-thread) + (print-mpair-curly-braces #f) (run-in-user-thread (lambda () ((namespace-variable-value 'install-eopl-exception-handler))))) diff --git a/collects/eopl/eopl.ss b/collects/eopl/eopl.ss index 0530588f1e..8b7e8630fc 100644 --- a/collects/eopl/eopl.ss +++ b/collects/eopl/eopl.ss @@ -3,7 +3,8 @@ "private/sllgen.ss" mzlib/trace mzlib/pretty - (rename r5rs r5rs:define define)) + (rename r5rs r5rs:define define) + (rename r5rs r5rs:quote quote)) (require-for-syntax "private/slldef.ss") (provide define-datatype @@ -12,13 +13,13 @@ ;; Special def that saves a quoted value at compile time in case ;; it's needed for `sllgen:make-define-datatypes': (define-syntax (eopl-define stx) - (syntax-case stx (quote) - [(_ name (quote def)) + (syntax-case stx (r5rs:quote) + [(_ name (r5rs:quote def)) (identifier? (syntax name)) (syntax/loc stx (begin (begin-for-syntax (hash-table-put! sllgen-def 'name (quote-syntax def))) - (define name (quote def))))] + (define name (r5rs:quote def))))] [(_ . rest) (syntax/loc stx (r5rs:define . rest))])) @@ -120,9 +121,9 @@ ;; if preds is empty, but list isn't, then recycle (loop obj all-preds) ;; otherwise check and element and recur. - (and (pair? obj) - ((car preds) (car obj)) - (loop (cdr obj) (cdr preds)))))))))) + (and (mpair? obj) + ((car preds) (mcar obj)) + (loop (mcdr obj) (cdr preds)))))))))) ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; diff --git a/collects/eopl/private/sllgen.ss b/collects/eopl/private/sllgen.ss index 6d96923a98..3187c55434 100644 --- a/collects/eopl/private/sllgen.ss +++ b/collects/eopl/private/sllgen.ss @@ -7,6 +7,7 @@ (module sllgen mzscheme (require mzlib/pretty + scheme/mpair "../datatype.ss" "sllboth.ss" mzlib/etc) @@ -982,7 +983,7 @@ (lambda (production) (sllgen:make-parse-table-production-entry production non-terminals first-table follow-table)) - (cdr table-entry)))) + (unbox (cdr table-entry))))) table)))) (define sllgen:make-parse-table-non-terminal-entry @@ -2070,16 +2071,15 @@ (define sllgen:unzip-buffer (lambda (trees n buf) (let ((ans (let consloop ((n n)) - (if (zero? n) buf (mcons '() (consloop (- n 1))))))) + (if (zero? n) + (list->mlist buf) + (mcons '() (consloop (- n 1))))))) (let loop ((trees trees) (ptr ans) (ctr n)) ; (eopl:printf "ctr = ~s trees = ~s~%" ctr trees) (cond - ((null? trees) (let loop ([ans ans]) - (if (null? ans) - null - (cons (mcar ans) (loop (mcdr ans)))))) + ((null? trees) (mlist->list ans)) ((zero? ctr) (loop trees ans n)) (else (set-mcar! ptr (cons (car trees) (mcar ptr))) @@ -2088,5 +2088,9 @@ (define sllgen:apply-reduction (lambda (lhs opcode args) (apply (eval opcode) - args))) + (map (lambda (v) + (if (list? v) + (list->mlist v) + v)) + args)))) )