EOPL quote and pair fixes

svn: r10318

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

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)))))

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))))))))))
 
   ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 

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))))
   )