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 f708005908a9019f48376f726dd5efdeb444685f..2a674b6a8ac93f3ab0f19f155bb6ef40a2e4cc34 100644 (file)
--- 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)))
 \f
 ;;;; 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))
-\f
-(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))))))
-\f
-(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