DataMuseum.dk

top - metrics - download

    Length: 28343 (0x6eb7)
    Types: TextFile
    Names: »syntax.scm.204«

└─⟦a0efdde77⟧ Bits:30001252 EUUGD11 Tape, 1987 Spring Conference Helsinki
    └─⟦this⟧ »EUUGD11/gnu-31mar87/scheme/scm/syntax.scm.204« 

TextFile

;;; -*-Scheme-*-
;;;
;;;	Copyright (c) 1984 Massachusetts Institute of Technology
;;;
;;;	This material was developed by the Scheme project at the
;;;	Massachusetts Institute of Technology, Department of
;;;	Electrical Engineering and Computer Science.  Permission to
;;;	copy this software, to redistribute it, and to use it for any
;;;	purpose is granted, subject to the following restrictions and
;;;	understandings.
;;;
;;;	1. Any copy made of this software must include this copyright
;;;	notice in full.
;;;
;;;	2. Users of this software agree to make their best efforts (a)
;;;	to return to the MIT Scheme project any improvements or
;;;	extensions that they make, so that these may be included in
;;;	future releases; and (b) to inform MIT of noteworthy uses of
;;;	this software.
;;;
;;;	3.  All materials developed as a consequence of the use of
;;;	this software shall duly acknowledge such use, in accordance
;;;	with the usual standards of acknowledging credit in academic
;;;	research.
;;;
;;;	4. MIT has made no warrantee or representation that the
;;;	operation of this software will be error-free, and MIT is
;;;	under no obligation to provide any services, by way of
;;;	maintenance, update, or otherwise.
;;;
;;;	5.  In conjunction with products arising from the use of this
;;;	material, there shall be no use of the name of the
;;;	Massachusetts Institute of Technology nor of any adaptation
;;;	thereof in any advertising, promotional, or sales literature
;;;	without prior written consent from MIT in each case.
;;;

;;;; SYNTAX: S-Expressions -> SCODE

(declare (usual-integrations))
\f


(define syntax)
(define syntax*)
(define install-declaration-hook!)
(define macro-spreader)

(define enable-scan-defines!)
(define with-scan-defines-enabled)
(define disable-scan-defines!)
(define with-scan-defines-disabled)

(define current-syntax-table)
(define set-current-syntax-table!)
(define with-syntax-table)
(define syntax-table?)
(define make-syntax-table)
(define extend-syntax-table)
(define copy-syntax-table)
(define lookup-syntax)
(define add-syntax!)
(define remove-syntax!)

(define current-syntax-environment)
(define set-current-syntax-environment!)
(define with-syntax-environment)

(define lambda-tag:unnamed (make-named-tag "UNNAMED-PROCEDURE"))
(define lambda-tag:fluid-let (make-named-tag "FLUID-LET-PROCEDURE"))
(define lambda-tag:let (make-named-tag "LET-PROCEDURE"))
(define lambda-tag:make-environment
  (make-named-tag "MAKE-ENVIRONMENT-PROCEDURE"))
(define lambda-tag:make-package (make-named-tag "MAKE-PACKAGE-PROCEDURE"))

(let ((external-make-sequence make-sequence)
      (external-make-lambda make-lambda)
      (make-declaration make-declaration))
\f


;;;; Dispatch Point

(define (syntax-expression expression)
  (cond ((pair? expression)
	 (let ((quantum (lookup-syntax (car expression))))
	   (if quantum
	       (fluid-let ((saved-keyword (car expression)))
		 (quantum expression))
	       (make-combination (syntax-expression (car expression))
				 (syntax-expressions (cdr expression))))))
	((symbol? expression)
	 (make-variable expression))
	(else
	 expression)))

(define (syntax-expressions expressions)
  (if (null? expressions)
      '()
      (cons (syntax-expression (car expressions))
	    (syntax-expressions (cdr expressions)))))

(define ((spread-arguments kernel) expression)
  (apply kernel (cdr expression)))

(define saved-keyword
  (make-interned-symbol ""))

(define (syntax-error message . irritant)
  (error (string-append message
			": "
			(symbol-print-name saved-keyword)
			" SYNTAX")
	 (cond ((null? irritant) *the-non-printing-object*)
	       ((null? (cdr irritant)) (car irritant))
	       (else irritant))))

(define (syntax-sequence subexpressions)
  (if (null? subexpressions)
      (syntax-error "No subforms in sequence")
      (make-sequence (syntax-sequentially subexpressions))))

(define (syntax-sequentially expressions)
  (if (null? expressions)
      '()
      ;; force eval order.
      (let ((first (syntax-expression (car expressions))))
	(cons first
	      (syntax-sequentially (cdr expressions))))))

(define (syntax-bindings bindings receiver)
  (cond ((null? bindings)
	 (receiver '() '()))
	((conjunction (pair? (car bindings))
		      (symbol? (caar bindings)))
	 (syntax-bindings (cdr bindings)
	   (lambda (names values)
	     (receiver (cons (caar bindings) names)
		       (cons (expand-binding-value (cdar bindings)) values)))))
	(else
	 (syntax-error "Badly-formed binding" (car bindings)))))
\f


;;;; Expanders

(define (expand-access chain cont)
  (if (symbol? (car chain))
      (cont (if (null? (cddr chain))
		(syntax-expression (cadr chain))
		(expand-access (cdr chain) make-access))
	    (car chain))
      (syntax-error "Non-symbolic variable" (car chain))))

(define (expand-binding-value rest)
  (cond ((null? rest) unassigned-object)
	((null? (cdr rest)) (syntax-expression (car rest)))
	(else (syntax-error "Too many forms in value" rest))))

(define expand-conjunction
  (let ()
    (define (expander forms)
      (if (null? (cdr forms))
	  (syntax-expression (car forms))
	  (make-conjunction (syntax-expression (car forms))
			    (expander (cdr forms)))))
    (named-lambda (expand-conjunction forms)
      (if (null? forms)
	  '#!TRUE
	  (expander forms)))))

(define expand-disjunction
  (let ()
    (define (expander forms)
      (if (null? (cdr forms))
	  (syntax-expression (car forms))
	  (make-disjunction (syntax-expression (car forms))
			    (expander (cdr forms)))))
    (named-lambda (expand-disjunction forms)
      (if (null? forms)
	  '#!FALSE
	  (expander forms)))))

(define (expand-lambda pattern body receiver)
  (define (loop pattern body)
    (if (pair? (car pattern))
	(loop (car pattern)
	      (make-lambda (cdr pattern) body))
	(receiver pattern body)))
  (if (pair? pattern)
      (loop pattern body)
      (receiver pattern body)))
\f


;;;; Quasiquote

(define expand-quasiquote
  (let ()
    (define quasiquote-tag 'QUASIQUOTE)
    (define quasiquote-unquoter-tag 'QUASIQUOTE-UNQUOTER)
    (define quasiquote-spreader-tag 'QUASIQUOTE-SPREADER)

    (define (expand expression)
      (if (pair? expression)
	  (cond ((eq? (car expression) quasiquote-unquoter-tag)
		 (cadr expression))
		((eq? (car expression) quasiquote-tag)
		 (expand (expand (cadr expression))))
		((eq? (car expression) quasiquote-spreader-tag)
		 (error "Misplaced ,@" 'EXPAND-QUASIQUOTE expression))
		((conjunction (pair? (car expression))
			      (eq? (caar expression) quasiquote-spreader-tag))
		 (expand-spread (cadr (car expression))
				(expand (cdr expression))))
		(else
		 (expand-pair (expand (car expression))
			      (expand (cdr expression)))))
	  (list 'QUOTE expression)))

    (define (expand-pair a d)
      (cond ((pair? d)
	     (cond ((eq? (car d) 'QUOTE)
		    (cond ((conjunction (pair? a) (eq? (car a) 'QUOTE))
			   (list 'QUOTE (cons (cadr a) (cadr d))))
			  ((list? (cadr d))
			   (cons* 'LIST
				  a
				  (mapcar (lambda (element)
					    (list 'QUOTE element))
					  (cadr d))))
			  (else
			   (list 'CONS a d))))
		   ((eq? (car d) 'CONS)
		    (cons* 'CONS* a (cdr d)))
		   ((memq (car d) '(LIST CONS*))
		    (cons* (car d) a (cdr d)))
		   (else
		    (list 'CONS a d))))
	    (else
	     (list 'CONS a d))))

    (define (expand-spread a d)
      (cond ((pair? d)
	     (cond ((eq? (car d) 'QUOTE)
		    (cond ((conjunction (pair? a) (eq? (car a) 'QUOTE))
			   (list 'QUOTE (append (cadr a) (cadr d))))
			  ((null? (cadr d))
			   a)
			  (else
			   (list 'APPEND a d))))
		   ((eq? (car d) 'APPEND)
		    (cons* (car d) a (cdr d)))
		   (else
		    (list 'APPEND a d))))
	    (else
	     (list 'APPEND a d))))

    (named-lambda (expand-quasiquote expression)
      (syntax-expression (expand expression)))))
\f


;;;; Basic Syntax

(define syntax-SCODE-QUOTE-form
  (spread-arguments
   (lambda (expression)
     (make-quotation (syntax-expression expression)))))

(define syntax-QUOTE-form
  (spread-arguments identity-procedure))

(define syntax-THE-ENVIRONMENT-form
  (spread-arguments make-the-environment))

(define syntax-UNASSIGNED?-form
  (spread-arguments make-unassigned?))

(define syntax-UNBOUND?-form
  (spread-arguments make-unbound?))

(define syntax-ACCESS-form
  (spread-arguments
   (lambda chain
     (expand-access chain make-access))))

(define syntax-SET!-form
  (spread-arguments
   (lambda (name . rest)
     ((syntax-extended-assignment name)
      (expand-binding-value rest)))))

(define syntax-DEFINE-form
  (spread-arguments
   (lambda (pattern . rest)
     (cond ((symbol? pattern)
	    (make-definition pattern
			     (expand-binding-value rest)))
	   ((pair? pattern)
	    (expand-lambda pattern (syntax-sequence rest)
	      (lambda (pattern body)
		(make-definition (car pattern)
				 (make-named-lambda (car pattern) (cdr pattern)
						    body)))))
	   (else
	    (syntax-error "Bad pattern" pattern))))))

(define syntax-SEQUENCE-form
  (spread-arguments
   (lambda actions
     (syntax-sequence actions))))

(define syntax-IN-PACKAGE-form
  (spread-arguments
   (lambda (environment . body)
     (make-in-package (syntax-expression environment)
		      (syntax-sequence body)))))

(define syntax-DELAY-form
  (spread-arguments
   (lambda (expression)
     (make-delay
      (syntax-expression expression)))))

;;;; Conditionals

(define syntax-IF-form
  (spread-arguments
   (lambda (predicate consequent . rest)
     (make-conditional (syntax-expression predicate)
		       (syntax-expression consequent)
		       (cond ((null? rest)
			      #!FALSE)
			     ((null? (cdr rest))
			      (syntax-expression (car rest)))
			     (else
			      (syntax-error "Too many forms" (cdr rest))))))))

(define syntax-COND-form
  (let ()
    (define (process-cond-clauses clause rest)
      (cond ((eq? (car clause) 'ELSE)
	     (if (null? rest)
		 (syntax-sequence (cdr clause))
		 (syntax-error "ELSE not last clause" rest)))
	    ((null? rest)
	     (if (cdr clause)
		 (make-conjunction (syntax-expression (car clause))
				   (syntax-sequence (cdr clause)))
		 (syntax-expression (car clause))))
	    ((null? (cdr clause))
	     (make-disjunction (syntax-expression (car clause))
			       (process-cond-clauses (car rest)
						     (cdr rest))))
	    (else
	     (make-conditional (syntax-expression (car clause))
			       (syntax-sequence (cdr clause))
			       (process-cond-clauses (car rest)
						     (cdr rest))))))
    (spread-arguments
     (lambda (clause . rest)
       (process-cond-clauses clause rest)))))

(define syntax-CONJUNCTION-form
  (spread-arguments
   (lambda forms
     (expand-conjunction forms))))

(define syntax-DISJUNCTION-form
  (spread-arguments
   (lambda forms
     (expand-disjunction forms))))
\f


;;;; Procedures

(define syntax-LAMBDA-form
  (spread-arguments
   (lambda (pattern . body)
     (expand-lambda pattern (syntax-sequence body) make-lambda))))

(define syntax-NAMED-LAMBDA-form
  (spread-arguments
   (lambda (pattern . body)
     (expand-lambda pattern (syntax-sequence body)
       (lambda (pattern body)
	 (make-named-lambda (car pattern) (cdr pattern) body))))))

(define syntax-LET-form
  (spread-arguments
   (lambda (name-or-pattern pattern-or-first . rest)
     (if (symbol? name-or-pattern)
	 (syntax-bindings pattern-or-first
	   (lambda (names values)
	     (make-combination (make-named-lambda name-or-pattern names
						  (syntax-sequence rest))
			       values)))
	 (syntax-bindings name-or-pattern
	   (lambda (names values)
	     (make-closed-block
	      lambda-tag:let names values
	      (syntax-sequence (cons pattern-or-first rest)))))))))

(define syntax-MAKE-PACKAGE-form
  (spread-arguments
   (lambda (name bindings . body)
     (if (symbol? name)
	 (syntax-bindings bindings
	   (lambda (names values)
	     (make-closed-block
	      lambda-tag:make-package
	      (cons name names)
	      (cons unassigned-object values)
	      (if (null? body)
		  (make-sequence* (make-assignment name the-environment-object)
				  the-environment-object)
		  (make-sequence* (make-assignment name the-environment-object)
				  (syntax-sequence body)
				  the-environment-object)))))
	 (syntax-error "Bad package name" name)))))

(define syntax-MAKE-ENVIRONMENT-form
  (spread-arguments
   (lambda body
     (make-closed-block
      lambda-tag:make-environment '() '()
      (if (null? body)
	  the-environment-object
	  (make-sequence* (syntax-sequence body)
			  the-environment-object))))))
\f


;;;; Syntax Extensions

(define syntax-LET-SYNTAX-form
  (spread-arguments
   (lambda (bindings . body)
     (syntax-bindings bindings
       (lambda (names values)
	 (with-syntax-table
	  (extend-syntax-table
	   (mapcar (lambda (name value)
		     (cons name
			   (scode-eval value
				       (current-syntax-environment))))
		   names
		   values)
	   (current-syntax-table))
	  (lambda ()
	    (syntax-sequence body))))))))

(define syntax-DEFINE-SYNTAX-form
  (spread-arguments
   (lambda (name value)
     (cond ((symbol? name)
	    (add-syntax! name
			 (scode-eval (syntax-expression value)
				     (current-syntax-environment))))
	   ((list? name)
	    (add-syntax! (car name)
			 (let ((transformer
				(scode-eval (syntax-NAMED-LAMBDA-form
					     `(NAMED-LAMBDA ,name ,value))
					    (current-syntax-environment))))
			   (lambda (expression)
			     (apply transformer (cdr expression))))))
	   (else
	    (syntax-error "Bad syntax description" name))))))

(define (syntax-MACRO-form expression)
  (make-combination* (expand-access '(MACRO-SPREADER '())
		       make-access)
		     (syntax-LAMBDA-form expression)))

(define (syntax-DEFINE-MACRO-form expression)
  (add-syntax! (caadr expression)
	       (macro-spreader
		(scode-eval (syntax-NAMED-LAMBDA-form expression)
			    (current-syntax-environment)))))

(set! macro-spreader
(named-lambda ((macro-spreader transformer) expression)
  (syntax-expression (apply transformer (cdr expression)))))
\f


;;;; Grab Bag

(define (syntax-ERROR-LIKE-form procedure-name)
  (spread-arguments
   (lambda (message . rest)
     (make-combination* (make-variable procedure-name)
			(syntax-expression message)
			(cond ((null? rest)
			       ;; Slightly crockish, but prevents
			       ;; hidden variable reference.
			       (make-access (make-null)
					    '*THE-NON-PRINTING-OBJECT*))
			      ((null? (cdr rest))
			       (syntax-expression (car rest)))
			      (else
			       (make-combination
				(make-access (make-null) 'LIST)
				(syntax-expressions rest))))
			(make-the-environment)))))

(define syntax-ERROR-form
  (syntax-ERROR-LIKE-form 'ERROR-PROCEDURE))

(define syntax-BKPT-form
  (syntax-ERROR-LIKE-form 'BREAKPOINT-PROCEDURE))

(define syntax-QUASIQUOTE-form
  (spread-arguments expand-quasiquote))
\f


;;;; FLUID-LET

(define syntax-FLUID-LET-form
  (spread-arguments
   (lambda (bindings . body)
     (syntax-fluid-bindings bindings
       (lambda (names values transfers-in transfers-out)
	 (make-closed-block
	  lambda-tag:fluid-let names values
	  (make-combination* (make-variable 'DYNAMIC-WIND)
			     (make-thunk (make-sequence transfers-in))
			     (make-thunk (syntax-sequence body))
			     (make-thunk (make-sequence transfers-out)))))))))

(define (syntax-fluid-bindings bindings receiver)
  (if (null? bindings)
      (receiver '() '() '() '())
      (syntax-fluid-bindings (cdr bindings)
	(syntax-fluid-binding (car bindings) receiver))))

(define (syntax-fluid-binding binding receiver)
  (if (pair? binding)
      (let ((transfer 
	     (let ((assignment (syntax-extended-assignment (car binding))))
	       (lambda (target source)
		 (make-assignment target
				  (assignment
				   (make-assignment source
						    unassigned-object))))))
	    (value (expand-binding-value (cdr binding)))
	    (inside-name (make-symbol "INSIDE-PLACEHOLDER"))
	    (outside-name (make-symbol "OUTSIDE-PLACEHOLDER")))
	(lambda (names values transfers-in transfers-out)
	  (receiver (cons* inside-name outside-name names)
		    (cons* value unassigned-object values)
		    (cons (transfer outside-name inside-name) transfers-in)
		    (cons (transfer inside-name outside-name) transfers-out))))
      (syntax-error "Binding not a list" binding)))
\f


;;;; Extended Assignment Syntax

(define (syntax-extended-assignment expression)
  (invert-expression (syntax-expression expression)))

(define (invert-expression target)
  (cond ((variable? target)
	 (invert-variable (variable-name target)))
	((access? target)
	 (access-components target invert-access))
	(else
	 (syntax-error "Bad target" target))))

(define ((invert-variable name) value)
  (make-assignment name value))

(define ((invert-access environment name) value)
  (make-combination* lexical-assignment environment name value))
\f


;;;; Declarations

;;; This phase of syntaxing doesn't recognize declarations, but passes
;;; them on to the optimizer for later processing.  MAKE-SEQUENCE takes
;;; care of converting crufty sequential declarations into scoped ones.

;;; However, all declarations are syntactically checked; the resulting
;;; DECLARATION objects all contain lists of standard declarations.
;;; Each standard declaration is a proper list with symbolic keyword.

(define syntax-LOCAL-DECLARE-form
  (spread-arguments
   (lambda (declarations . body)
     (make-declaration (process-declarations declarations)
		       (syntax-sequence body)))))

(define syntax-DECLARE-form
  (spread-arguments
   (lambda declarations
     (cons declaration-tag (mapcar process-declaration declarations)))))

(define declaration-tag
  '(DECLARATION))

(define (syntaxer-declaration? object)
  (conjunction (pair? object)
	       (eq? (car object) declaration-tag)))

(define (syntaxer-declaration-text declaration)
  (cdr declaration))

(define (process-declarations declarations)
  (if (list? declarations)
      (mapcar process-declaration declarations)
      (syntax-error "Illegal declaration list" declarations)))

(define (process-declaration declaration)
  (cond ((symbol? declaration)
	 (list declaration))
	((conjunction (list? declaration)
		      (not (null? declaration))
		      (symbol? (car declaration)))
	 declaration)
	(else
	 (syntax-error "Illegal declaration" declaration))))

(define (convert-declarations actions)
  (cond ((null? actions)
	 '())
	((syntaxer-declaration? (car actions))
	 (list (make-declaration
		(syntaxer-declaration-text (car actions))
		(make-sequence (convert-declarations (cdr actions))))))
	(else
	 (cons (car actions)
	       (convert-declarations (cdr actions))))))

(set! install-declaration-hook!
(named-lambda (install-declaration-hook! new-make)
  (set! make-declaration
	(new-make make-declaration))))
\f


;;;; SCODE Constructors

(define unassigned-object
 (make-unassigned-object))

(define the-environment-object
  (make-the-environment))

(define (make-conjunction first second)
  (make-conditional first second #!FALSE))

(define (make-combination* operator . operands)
  (make-combination operator operands))

(define (make-sequence* . operands)
  (make-sequence operands))

(define (make-sequence operands)
  (internal-make-sequence (convert-declarations operands)))

(define (make-thunk body)
  (make-lambda '() body))

(define (make-lambda pattern body)
  (make-named-lambda lambda-tag:unnamed pattern body))

(define (make-named-lambda name pattern body)
  (if (not (symbol? name))
      (syntax-error "Name of lambda expression must be a symbol" name))
  (parse-lambda-list pattern
    (lambda (required optional rest)
      (internal-make-lambda name required optional rest body))))

(define (make-closed-block tag names values body)
  (make-combination (internal-make-lambda tag names '() '() body)
		    values))
\f


(define (parse-lambda-list lambda-list continuation)
  (let ((required '())
	(optional '())
	(rest '()))

    (define (parse-required pattern)
      (cond ((null? pattern)
	     (finish-parse))
	    ((not (pair? pattern))
	     (parse-tail pattern))
	    ((eq? (car pattern)
		  (access lambda-optional-tag lambda-package))
	     (parse-optional (cdr pattern)))
	    ((symbol? (car pattern))
	     (set! required (cons (car pattern) required))
	     (parse-required (cdr pattern)))
	    (else
	     (bad-lambda-list pattern))))

    (define (parse-optional pattern)
      (cond ((null? pattern)
	     (finish-parse))
	    ((not (pair? pattern))
	     (parse-tail pattern))
	    ((eq? (car pattern)
		  (access lambda-optional-tag lambda-package))
	     (bad-lambda-list pattern))
	    ((symbol? (car pattern))
	     (set! optional (cons (car pattern) optional))
	     (parse-optional (cdr pattern)))
	    (else
	     (bad-lambda-list pattern))))

    (define (parse-tail name)
      (if (not (symbol? name))
	  (syntax-error "Bad tail variable name" name))
      (set! rest name)
      (finish-parse))

    (define (bad-lambda-list pattern)
      (syntax-error "Illegally-formed lambda-list" pattern))

    (define (finish-parse)
      (continuation (reverse! required)
		    (reverse! optional)
		    rest))

    (parse-required lambda-list)))
\f


;;;; Scan Defines

(define no-scan-make-sequence
  external-make-sequence)

(define (scanning-make-sequence actions)
  (scan-defines (external-make-sequence actions)
    make-open-block))

(define (no-scan-make-lambda name required optional rest body)
  (external-make-lambda name required optional rest '() body))

(define (scanning-make-lambda name required optional rest body)
  (scan-defines body
    (lambda (auxiliary body*)
      (external-make-lambda name required optional rest auxiliary body*))))

(define internal-make-sequence)
(define internal-make-lambda)

(set! enable-scan-defines!
(named-lambda (enable-scan-defines!)
  (set! internal-make-sequence scanning-make-sequence)
  (set! internal-make-lambda scanning-make-lambda)))

(set! with-scan-defines-enabled
(named-lambda (with-scan-defines-enabled thunk)
  (fluid-let ((internal-make-sequence scanning-make-sequence)
	      (internal-make-lambda scanning-make-lambda))
    (thunk))))

(set! disable-scan-defines!
(named-lambda (disable-scan-defines!)
  (set! internal-make-sequence no-scan-make-sequence)
  (set! internal-make-lambda no-scan-make-lambda)))

(set! with-scan-defines-disabled
(named-lambda (with-scan-defines-disabled thunk)
  (fluid-let ((internal-make-sequence no-scan-make-sequence)
	      (internal-make-lambda no-scan-make-lambda))
    (thunk))))
\f


;;;; Top Level Syntaxers

(define ((make-syntax-top-level syntaxer)
	 expression #!optional table environment)
  (if (unassigned? table)
      (syntaxer expression)
      (with-syntax-table table
	(lambda ()
	  (if (unassigned? environment)
	      (syntaxer expression)
	      (with-syntax-environment environment
		(lambda ()
		  (syntaxer expression))))))))

(set! syntax (make-syntax-top-level syntax-expression))
(set! syntax* (make-syntax-top-level syntax-sequence))
\f


;;;; Syntax Table

(define syntax-table)

(set! current-syntax-table
(named-lambda (current-syntax-table)
  syntax-table))

(set! set-current-syntax-table!
(named-lambda (set-current-syntax-table! new-table)
  (if (not (syntax-table? new-table))
      (error "Not a syntax table" 'SET-CURRENT-SYNTAX-TABLE new-table))
  (set! syntax-table new-table)))

(set! with-syntax-table
(named-lambda (with-syntax-table new-table thunk)
  (define old-table)
  (if (not (syntax-table? new-table))
      (error "Not a syntax table" 'WITH-SYNTAX-TABLE new-table))
  (dynamic-wind (lambda ()
		  (set! old-table (set! syntax-table new-table)))
		thunk
		(lambda ()
		  (set! new-table (set! syntax-table (set! old-table)))))))

(define syntax-table-tag
  '(SYNTAX-TABLE))

(set! syntax-table?
(named-lambda (syntax-table? object)
  (conjunction (pair? object)
	       (eq? (car object) syntax-table-tag))))

(set! make-syntax-table
(named-lambda (make-syntax-table alist)
  (list syntax-table-tag alist)))

(set! extend-syntax-table
(named-lambda (extend-syntax-table alist #!optional table)
  (cond ((unassigned? table)
	 (set! table (current-syntax-table)))
	((not (syntax-table? table))
	 (error "Not a syntax table" 'EXTEND-SYNTAX-TABLE table)))
  (cons syntax-table-tag
	(cons alist (cdr table)))))
\f


(set! copy-syntax-table
(named-lambda (copy-syntax-table #!optional table)
  (cond ((unassigned? table)
	 (set! table (current-syntax-table)))
	((not (syntax-table? table))
	 (error "Not a syntax table" 'COPY-SYNTAX-TABLE table)))
  (cons syntax-table-tag
	(mapcar (lambda (alist)
		  (mapcar (lambda (pair)
			    (cons (car pair) (cdr pair)))
			  alist))
		(cdr table)))))

(set! lookup-syntax
(named-lambda (lookup-syntax keyword #!optional table)
  (cond ((unassigned? table)
	 (set! table (current-syntax-table)))
	((not (syntax-table? table))
	 (error "Not a syntax table" 'LOOKUP-SYNTAX table)))
  (let loop ((frames (cdr table)))
    (conjunction (not (null? frames))
		 (let ((entry (assq keyword (car frames))))
		   (if entry
		       (cdr entry)
		       (loop (cdr frames))))))))

(set! add-syntax!
(named-lambda (add-syntax! name quantum #!optional table)
  (cond ((unassigned? table)
	 (set! table (current-syntax-table)))
	((not (syntax-table? table))
	 (error "Not a syntax table" 'ADD-SYNTAX! table)))
  (let ((vcell (assq name (cadr table))))
    (if vcell
	(set-cdr! vcell quantum)
	(set-car! (cdr table)
		  (cons (cons name quantum)
			(cadr table)))))
  name))

(set! remove-syntax!
(named-lambda (remove-syntax! name #!optional table)
  (cond ((unassigned? table)
	 (set! table (current-syntax-table)))
	((not (syntax-table? table))
	 (error "Not a syntax table" 'REMOVE-SYNTAX! table)))
  (if (assq name (cadr table))
      (set-car! (cdr table) 
		(del-assq! name (cadr table))))
  name))
\f


;;;; Syntax Environment

(define syntax-environment)

(set! current-syntax-environment
(named-lambda (current-syntax-environment)
  syntax-environment))

(set! set-current-syntax-environment!
(named-lambda (set-current-syntax-environment! new-environment)
  (if (not (disjunction (environment? new-environment)
			(eq? new-environment system-global-environment)))
      (error "Not an environment" 'SET-CURRENT-SYNTAX-ENVIRONMENT!
	     new-environment))
  (set! syntax-environment new-environment)))

(set! with-syntax-environment
(named-lambda (with-syntax-environment new-environment thunk)
  (define old-environment)
  (if (not (disjunction (environment? new-environment)
			(eq? new-environment system-global-environment)))
      (error "Not an environment" 'WITH-SYNTAX-ENVIRONMENT
	     new-environment))
  (dynamic-wind (lambda ()
		  (set! old-environment
			(set! syntax-environment new-environment)))
		thunk
		(lambda ()
		  (set! new-environment
			(set! syntax-environment
			      (set! old-environment)))))))
\f


;;;; Default Syntax

(enable-scan-defines!)

(set-current-syntax-table!
 (make-syntax-table
  `((ACCESS           . ,syntax-ACCESS-form)
    (BKPT             . ,syntax-BKPT-form)
    (COND             . ,syntax-COND-form)
    (CONJUNCTION      . ,syntax-CONJUNCTION-form)
    (DECLARE          . ,syntax-DECLARE-form)
    (DEFINE           . ,syntax-DEFINE-form)
    (DEFINE-SYNTAX    . ,syntax-DEFINE-SYNTAX-form)
    (DEFINE-MACRO     . ,syntax-DEFINE-MACRO-form)
    (DELAY            . ,syntax-DELAY-form)
    (DISJUNCTION      . ,syntax-DISJUNCTION-form)
    (ERROR            . ,syntax-ERROR-form)
    (FLUID-LET        . ,syntax-FLUID-LET-form)
    (IF               . ,syntax-IF-form)
    (IN-PACKAGE       . ,syntax-IN-PACKAGE-form)
    (LAMBDA           . ,syntax-LAMBDA-form)
    (LET              . ,syntax-LET-form)
    (LET-SYNTAX       . ,syntax-LET-SYNTAX-form)
    (LOCAL-DECLARE    . ,syntax-LOCAL-DECLARE-form)
    (MACRO            . ,syntax-MACRO-form)
    (MAKE-ENVIRONMENT . ,syntax-MAKE-ENVIRONMENT-form)
    (MAKE-PACKAGE     . ,syntax-MAKE-PACKAGE-form)
    (NAMED-LAMBDA     . ,syntax-NAMED-LAMBDA-form)
    ;; The funniness here prevents QUASIQUOTE from being seen as
    ;; a nested backquote.
    (,'QUASIQUOTE       . ,syntax-QUASIQUOTE-form)
    (QUOTE            . ,syntax-QUOTE-form)
    (SCODE-QUOTE      . ,syntax-SCODE-QUOTE-form)
    (SEQUENCE         . ,syntax-SEQUENCE-form)
    (SET!             . ,syntax-SET!-form)
    (THE-ENVIRONMENT  . ,syntax-THE-ENVIRONMENT-form)
    (UNASSIGNED?      . ,syntax-UNASSIGNED?-form)
    (UNBOUND?         . ,syntax-UNBOUND?-form)
    )))
\f


;;; end SCHEME-SYNTAXER package.
)