From: Taylor R Campbell <campbell@mumble.net>
Date: Wed, 23 Sep 2009 17:53:00 +0000 (-0400)
Subject: Eliminate unsyntaxer's logic for FLUID-LET.
X-Git-Tag: 20100708-Gtk~318
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=92a579f7d2e8905d0c949cb9eb9bee5cefb45ed0;p=mit-scheme.git

Eliminate unsyntaxer's logic for FLUID-LET.

This code was fragile, and has neither worked nor even been reached
in at least eight years, so eliminating it doesn't really reduce any
functionality.
---

diff --git a/src/runtime/unsyn.scm b/src/runtime/unsyn.scm
index f70800590..2a674b6a8 100644
--- a/src/runtime/unsyn.scm
+++ b/src/runtime/unsyn.scm
@@ -100,12 +100,6 @@ USA.
       (cons (unsyntax-object (car objects))
 	    (unsyntax-objects (cdr objects)))
       '()))
-
-(define (unsyntax-error keyword message . irritants)
-  (apply error
-	 (cons (string-append "UNSYNTAX: " (symbol-name keyword) ": "
-			      message)
-	       irritants)))
 
 ;;;; Unsyntax Quanta
 
@@ -406,17 +400,12 @@ USA.
 		    (if (and (null? optional)
 			     (not rest)
 			     (= (length required) (length operands)))
-			(cond ((or (eq? name lambda-tag:unnamed)
-				   (eq? name lambda-tag:let))
-			       `(LET ,(unsyntax-let-bindings required operands)
-				  ,@(with-bindings required '() #F
-						   unsyntax-sequence body)))
-			      ((eq? name lambda-tag:fluid-let)
-			       (unsyntax/fluid-let required
-						   operands
-						   body
-						   ordinary-combination))
-			      (else (ordinary-combination)))
+			(if (or (eq? name lambda-tag:unnamed)
+				(eq? name lambda-tag:let))
+			    `(LET ,(unsyntax-let-bindings required operands)
+			       ,@(with-bindings required '() #F
+						unsyntax-sequence body))
+			    (ordinary-combination))
 			(ordinary-combination)))))
 	       (else
 		(ordinary-combination))))))))
@@ -451,103 +440,4 @@ USA.
 	       (cdadr (caddr (car expression)))
 	       (cdr expression))
 	 ,@(cddr (caddr (car expression))))
-      expression))
-
-(define (unsyntax/fluid-let names values body if-malformed)
-  (combination-components body
-    (lambda (operator operands)
-      ;; `fluid-let' expressions are complicated.  Rather than scan
-      ;; the entire expresion to find out if it has any substitutable
-      ;; subparts, we just treat it as malformed if there are active
-      ;; substitutions.
-      (cond ((pair? substitutions)
-	     (if-malformed))
-	    ((and (or (absolute-reference-to? operator 'SHALLOW-FLUID-BIND)
-		      (and (variable? operator)
-			   (eq? (variable-name operator) 'SHALLOW-FLUID-BIND)))
-		  (pair? operands)
-		  (lambda? (car operands))
-		  (pair? (cdr operands))
-		  (lambda? (cadr operands))
-		  (pair? (cddr operands))
-		  (lambda? (caddr operands))
-		  (null? (cdddr operands)))
-	     (unsyntax/fluid-let/shallow names values operands))
-	    ((and (eq? operator (ucode-primitive with-saved-fluid-bindings 1))
-		  (null? names)
-		  (null? values)
-		  (pair? operands)
-		  (lambda? (car operands))
-		  (null? (cdr operands)))
-	     (unsyntax/fluid-let/deep (car operands)))
-	    (else
-	     (if-malformed))))))
-
-(define (unsyntax/fluid-let/shallow names values operands)
-  names
-  `(FLUID-LET ,(unsyntax-let-bindings
-		(map extract-transfer-var
-		     (sequence-actions (lambda-body (car operands))))
-		(let every-other ((values values))
-		  (if (pair? values)
-		      (cons (car values) (every-other (cddr values)))
-		      '())))
-     ,@(lambda-components** (cadr operands)
-	 (lambda (name required optional rest body)
-	   name required optional rest
-	   (with-bindings required optional rest
-			  unsyntax-sequence body)))))
-
-(define (extract-transfer-var assignment)
-  (assignment-components assignment
-    (lambda (name value)
-      name
-      (cond ((assignment? value)
-	     (assignment-components value (lambda (name value) value name)))
-	    ((combination? value)
-	     (combination-components value
-	       (lambda (operator operands)
-		 (cond ((eq? operator (ucode-primitive lexical-assignment))
-			`(ACCESS ,(cadr operands)
-				 ,@(unexpand-access (car operands))))
-		       (else
-			(unsyntax-error 'FLUID-LET
-					"Unknown SCODE form"
-					assignment))))))
-	    (else
-	     (unsyntax-error 'FLUID-LET "Unknown SCODE form" assignment))))))
-
-(define (unsyntax/fluid-let/deep expression)
-  (let ((body (lambda-body expression)))
-    (let loop
-	((actions (sequence-actions body))
-	 (receiver
-	  (lambda (bindings body)
-	    `(FLUID-LET ,bindings ,@body))))
-      (let ((action (car actions)))
-	(if (and (combination? action)
-		 (or (eq? (combination-operator action)
-			  (ucode-primitive add-fluid-binding! 3))
-		     (eq? (combination-operator action)
-			  (ucode-primitive make-fluid-binding! 3))))
-	    (loop (cdr actions)
-	      (lambda (bindings body)
-		(receiver (cons (unsyntax-fluid-assignment action) bindings)
-			  body)))
-	    (receiver '() (unsyntax-objects actions)))))))
-
-(define (unsyntax-fluid-assignment combination)
-  (let ((operands (combination-operands combination)))
-    (let ((environment (car operands))
-	  (name (cadr operands))
-	  (value (caddr operands)))
-      (cond ((symbol? name)
-	     `((ACCESS ,name ,(unsyntax-object environment))
-	       ,(unsyntax-object value)))
-	    ((quotation? name)
-	     (let ((variable (quotation-expression name)))
-	       (if (variable? variable)
-		   `(,(variable-name variable) ,(unsyntax-object value))
-		   (unsyntax-error 'FLUID-LET "unexpected name" name))))
-	    (else
-	     (unsyntax-error 'FLUID-LET "unexpected name" name))))))
\ No newline at end of file
+      expression))
\ No newline at end of file