Import Upstream version 2a6upstream/2a6

1 files changed, 103 insertions, 0 deletions

diff --git a/scainit.scm b/scainit.scm
new file mode 100644
index 0000000..1103bc6
--- /dev/null
+++ b/scainit.scm
@@ -0,0 +1,103 @@
+;;; "scainit.scm" Syntax-case macros port to SLIB	-*- Scheme -*-
+;;; Copyright (C) 1992 R. Kent Dybvig
+;;;
+;;; Permission to copy this software, in whole or in part, to use this
+;;; software for any lawful purpose, and to redistribute this software
+;;; is granted subject to the restriction that all copies made of this
+;;; software must include this copyright notice in full.  This software
+;;; is provided AS IS, with NO WARRANTY, EITHER EXPRESS OR IMPLIED,
+;;; INCLUDING BUT NOT LIMITED TO IMPLIED WARRANTIES OF MERCHANTABILITY
+;;; OR FITNESS FOR ANY PARTICULAR PURPOSE.  IN NO EVENT SHALL THE
+;;; AUTHORS BE LIABLE FOR CONSEQUENTIAL OR INCIDENTAL DAMAGES OF ANY
+;;; NATURE WHATSOEVER.
+
+;;; From: Harald Hanche-Olsen <hanche@imf.unit.no>
+
+;;; compat.ss
+;;; Robert Hieb & Kent Dybvig
+;;; 92/06/18
+
+(require 'common-list-functions)	;to pick up EVERY
+(define syncase:andmap comlist:every)
+
+; In Chez Scheme "(syncase:void)" returns an object that is ignored by the
+; REP loop.  It is returned whenever a "nonspecified" value is specified
+; by the standard.  The following should pick up an appropriate value.
+
+(define syncase:void
+   (let ((syncase:void-object (if #f #f)))
+      (lambda () syncase:void-object)))
+
+(define syncase:eval-hook slib:eval)
+
+(define syncase:error-hook slib:error)
+
+(define syncase:new-symbol-hook
+  (let ((c 0))
+    (lambda (string)
+      (set! c (+ c 1))
+      (string->symbol
+       (string-append string ":Sca" (number->string c))))))
+
+(define syncase:put-global-definition-hook #f)
+(define syncase:get-global-definition-hook #f)
+(let ((*macros* '()))
+  (set! syncase:put-global-definition-hook
+	(lambda (symbol binding)
+	  (let ((pair (assq symbol *macros*)))
+	    (if pair
+		(set-cdr! pair binding)
+		(set! *macros* (cons (cons symbol binding) *macros*))))))
+  (set! syncase:get-global-definition-hook
+	(lambda (symbol)
+	  (let ((pair (assq symbol *macros*)))
+	    (and pair (cdr pair))))))
+
+
+;;;! expand.pp requires list*
+(define (syncase:list* . args)
+  (if (null? args)
+      '()
+      (let ((r (reverse args)))
+	(append (reverse (cdr r))
+		(car r)			; Last arg
+		'()))))			; Make sure the last arg is copied
+
+(define syntax-error syncase:error-hook)
+(define impl-error slib:error)
+
+(define base:eval slib:eval)
+(define syncase:eval base:eval)
+(define macro:eval base:eval)
+(define syncase:expand #f)
+(define macro:expand #f)
+(define (syncase:expand-install-hook expand)
+  (set! syncase:eval (lambda (x) (base:eval (expand x))))
+  (set! macro:eval syncase:eval)
+  (set! syncase:expand expand)
+  (set! macro:expand syncase:expand))
+;;; We Need This for bootstrapping purposes:
+(define (syncase:load <pathname>)
+  (slib:eval-load <pathname> syncase:eval))
+(define macro:load syncase:load)
+
+(define syncase:sanity-check #f)
+;;; LOADING THE SYSTEM ITSELF:
+(let ((here (lambda (file)
+	      (in-vicinity (library-vicinity) file)))
+      (scmhere (lambda (file)
+		 (in-vicinity (library-vicinity) file (scheme-file-suffix)))))
+  (for-each (lambda (file) (slib:load (here file)))
+	    '("scaoutp"
+	      "scaglob"
+	      "scaexpp"))
+  (syncase:expand-install-hook expand-syntax)
+  (syncase:load (here "scamacr"))
+  (set! syncase:sanity-check
+	(lambda ()
+	  (syncase:load (scmhere "sca-exp"))
+	  (syncase:expand-install-hook expand-syntax)
+	  (syncase:load (scmhere "sca-macr")))))
+
+(provide 'syntax-case)
+(provide 'macro)