*** empty log message ***

module/language/r5rs/expand.scm

@@ -66,20 +66,16 @@
 (define remprop symbol-property-remove!)
 
 (define syncase-module (current-module))
+(define guile-eval eval)
+(define (eval x)
+  (if (and (pair? x) (equal? (car x) "noexpand"))
+      (cdr x)
+      (guile-eval x syncase-module)))
 
-(define (sc-eval x) (eval x syncase-module))
+(define guile-error error)
+(define (error who format-string why what)
+  (guile-error why what))
 
-(load "psyntax.scm")
+(load "psyntax.pp")
 
 (define expand sc-expand)
-
-(define (rebuild)
-  (call-with-input-file "psyntax.ss"
-    (lambda (in)
-      (call-with-output-file "psyntax.scm"
-	(lambda (out)
-	  (do ((obj (read in) (read in)))
-	      ((eof-object? obj))
-	    (write (sc-expand obj 'c '(eval load compile)) out)))))))
-
-;(rebuild)

module/language/r5rs/psyntax.boot

@@ -1,75 +0,0 @@
-;;; psyntax.ss -> psyntax.scm
-
-;; Copyright (C) 2001 Free Software Foundation, Inc.
-
-;; This program is free software; you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation; either version 2, or (at your option)
-;; any later version.
-;; 
-;; This program is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
-;; GNU General Public License for more details.
-;; 
-;; You should have received a copy of the GNU General Public License
-;; along with this program; see the file COPYING.  If not, write to
-;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
-;; Boston, MA 02111-1307, USA.
-
-;;; Code:
-
-(define sc-expand #f)
-(define $sc-put-cte #f)
-(define bound-identifier=? #f)
-(define datum->syntax-object #f)
-(define free-identifier=? #f)
-(define generate-temporaries #f)
-(define identifier? #f)
-(define syntax-object->datum #f)
-(define syntax-rules #f)
-(define syntax-error #f)
-(define $syntax-dispatch #f)
-
-(define void (lambda () (if #f #f)))
-
-(define andmap
-  (lambda (f first . rest)
-    (or (null? first)
-	(if (null? rest)
-	    (let andmap ((first first))
-	      (let ((x (car first)) (first (cdr first)))
-		(if (null? first)
-		    (f x)
-		    (and (f x) (andmap first)))))
-	    (let andmap ((first first) (rest rest))
-	      (let ((x (car first))
-		    (xr (map car rest))
-		    (first (cdr first))
-		    (rest (map cdr rest)))
-		(if (null? first)
-		    (apply f (cons x xr))
-		    (and (apply f (cons x xr)) (andmap first rest)))))))))
-
-(define ormap
-  (lambda (proc list1)
-    (and (not (null? list1))
-	 (or (proc (car list1)) (ormap proc (cdr list1))))))
-
-(define putprop set-symbol-property!)
-(define getprop symbol-property)
-(define remprop symbol-property-remove!)
-
-(define core-eval eval)
-(define (eval x) (core-eval (cadr x) (interaction-environment)))
-
-(debug-set! stack 0)
-(load "psyntax.pp")
-
-(call-with-input-file "psyntax.ss"
-  (lambda (in)
-    (call-with-output-file "psyntax.scm"
-      (lambda (out)
-	(do ((obj (read in) (read in)))
-	    ((eof-object? obj))
-	  (write (sc-expand obj) out))))))

module/language/r5rs/psyntax.pp

@@ -8198,8 +8198,8 @@
                           (cadr g765)
                           (g400 g765 '() g764 g763 g761 g762))))
                   (g263 (g264 '((top))) (cons g762 (g265 '((top)))))))
-               'c
+               'e
-               '(eval load compile)
+               '(eval)
                ((lambda (g766) (begin (g366 g766 '*top*) g766))
                 (g304 '() '() '()))))
             (set! identifier? (lambda (g705) (g255 g705)))

module/language/r5rs/psyntax.ss

@@ -432,11 +432,17 @@
 
 (define annotation? (lambda (x) #f))
 
-(define top-level-eval-hook sc-eval)
+(define top-level-eval-hook
+  (lambda (x)
+    (eval `(,noexpand ,x))))
 
-(define local-eval-hook sc-eval)
+(define local-eval-hook
+  (lambda (x)
+    (eval `(,noexpand ,x))))
 
-(define error-hook (lambda (who why what) (error why what)))
+(define error-hook
+  (lambda (who why what)
+    (error who "~a ~s" why what)))
 
 (define-syntax gensym-hook
   (syntax-rules ()