home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / mitsch75.zip / scheme-7_5_17-src.zip / scheme-7.5.17 / src / runtime / syntax.scm < prev    next >
Text File  |  2001-03-21  |  25KB  |  770 lines
  1. #| -*-Scheme-*-
  2.  
  3. $Id: syntax.scm,v 14.33 2001/03/21 19:15:18 cph Exp $
  4.  
  5. Copyright (c) 1988-2001 Massachusetts Institute of Technology
  6.  
  7. This program is free software; you can redistribute it and/or modify
  8. it under the terms of the GNU General Public License as published by
  9. the Free Software Foundation; either version 2 of the License, or (at
  10. your option) any later version.
  11.  
  12. This program is distributed in the hope that it will be useful, but
  13. WITHOUT ANY WARRANTY; without even the implied warranty of
  14. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  15. General Public License for more details.
  16.  
  17. You should have received a copy of the GNU General Public License
  18. along with this program; if not, write to the Free Software
  19. Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
  20. 02111-1307, USA.
  21. |#
  22.  
  23. ;;;; SYNTAX: S-Expressions -> SCODE
  24. ;;; package: (runtime syntaxer)
  25.  
  26. (declare (usual-integrations))
  27.  
  28. (define (initialize-package!)
  29.   (set-fluid-let-type! 'SHALLOW)
  30.   (enable-scan-defines!)
  31.   (set! *disallow-illegal-definitions?* #t)
  32.   (set! hook/syntax-expression default/syntax-expression)
  33.   (set! system-global-syntax-table (make-system-global-syntax-table))
  34.   (set-environment-syntax-table! system-global-environment
  35.                  system-global-syntax-table)
  36.   (set! user-initial-syntax-table
  37.     (make-syntax-table system-global-syntax-table))
  38.   (set-environment-syntax-table! user-initial-environment
  39.                  user-initial-syntax-table))
  40.  
  41. (define system-global-syntax-table)
  42. (define user-initial-syntax-table)
  43. (define *syntax-table*)
  44. (define *current-keyword* #f)
  45. (define *syntax-top-level?*)
  46. (define *disallow-illegal-definitions?*)
  47.  
  48. (define (make-system-global-syntax-table)
  49.   (let ((table (make-syntax-table)))
  50.     (for-each (lambda (entry)
  51.         (syntax-table-define table (car entry)
  52.           (make-primitive-syntaxer (cadr entry))))
  53.           `(
  54.         ;; R*RS special forms
  55.         (BEGIN ,syntax/begin)
  56.         (COND ,syntax/cond)
  57.         (DEFINE ,syntax/define)
  58.         (DELAY ,syntax/delay)
  59.         (IF ,syntax/if)
  60.         (LAMBDA ,syntax/lambda)
  61.         (LET ,syntax/let)
  62.         (OR ,syntax/or)
  63.         (QUOTE ,syntax/quote)
  64.         (SET! ,syntax/set!)
  65.  
  66.         ;; Syntax extensions
  67.         (DEFINE-SYNTAX ,syntax/define-syntax)
  68.         (DEFINE-MACRO ,syntax/define-macro)
  69.         (LET-SYNTAX ,syntax/let-syntax)
  70.         (MACRO ,syntax/lambda)
  71.         (USING-SYNTAX ,syntax/using-syntax)
  72.  
  73.         ;; Environment extensions
  74.         (ACCESS ,syntax/access)
  75.         (IN-PACKAGE ,syntax/in-package)
  76.         (THE-ENVIRONMENT ,syntax/the-environment)
  77.         (UNASSIGNED? ,syntax/unassigned?)
  78.         ;; To facilitate upgrade to new option argument mechanism.
  79.         (DEFAULT-OBJECT? ,syntax/unassigned?)
  80.  
  81.         ;; Miscellaneous extensions
  82.         (DECLARE ,syntax/declare)
  83.         (FLUID-LET ,syntax/fluid-let)
  84.         (LOCAL-DECLARE ,syntax/local-declare)
  85.         (NAMED-LAMBDA ,syntax/named-lambda)
  86.         (SCODE-QUOTE ,syntax/scode-quote)))
  87.     table))
  88.  
  89. ;;;; Top Level Syntaxers
  90.  
  91. (define (syntax expression #!optional table)
  92.   (syntax-top-level 'SYNTAX syntax-expression expression
  93.             (if (default-object? table) #f table)))
  94.  
  95. (define (syntax* expressions #!optional table)
  96.   (syntax-top-level 'SYNTAX* syntax-sequence expressions
  97.             (if (default-object? table) #f table)))
  98.  
  99. (define (syntax-top-level name syntaxer expression table)
  100.   (let ((scode
  101.      (fluid-let ((*syntax-table*
  102.               (if table
  103.               (begin
  104.                 (if (not (syntax-table? table))
  105.                 (error:wrong-type-argument table
  106.                                "syntax table"
  107.                                name))
  108.                 table)
  109.               (if (unassigned? *syntax-table*)
  110.                   (nearest-repl/syntax-table)
  111.                   *syntax-table*)))
  112.              (*current-keyword* #f))
  113.        (syntaxer #t expression))))
  114.     (if *disallow-illegal-definitions?*
  115.     (check-for-illegal-definitions scode))
  116.     scode))
  117.  
  118. (define (syntax/top-level?)
  119.   *syntax-top-level?*)
  120.  
  121. (define (environment-syntax-table environment)
  122.   (environment-lookup environment syntax-table-tag))
  123.  
  124. (define (set-environment-syntax-table! environment table)
  125.   (if (not (interpreter-environment? environment))
  126.       (error:wrong-type-argument environment
  127.                  "interpreter environment"
  128.                  'SET-ENVIRONMENT-SYNTAX-TABLE!))
  129.   (local-assignment environment syntax-table-tag table))
  130.  
  131. (define-integrable syntax-table-tag
  132.   ((ucode-primitive string->symbol)
  133.    "#[(runtime syntax-table)syntax-table-tag]"))
  134.  
  135. (define-integrable (syntax-subsequence expressions)
  136.   (syntax-sequence #f expressions))
  137.  
  138. (define (syntax-sequence top-level? original-expressions)
  139.   (make-scode-sequence
  140.    (syntax-sequence-internal top-level? original-expressions)))
  141.  
  142. (define (syntax-sequence-internal top-level? original-expressions)
  143.   (if (null? original-expressions)
  144.       (syntax-error "no subforms in sequence")
  145.       (let process ((expressions original-expressions))
  146.     (cond ((pair? expressions)
  147.            ;; Force eval order.  This is required so that special
  148.            ;; forms such as `define-syntax' work correctly.
  149.            (let ((first (syntax-expression top-level? (car expressions))))
  150.          (cons first (process (cdr expressions)))))
  151.           ((null? expressions)
  152.            '())
  153.           (else
  154.            (syntax-error "bad sequence" original-expressions))))))
  155.  
  156. (define-integrable (syntax-subexpression expression)
  157.   (syntax-expression #f expression))
  158.  
  159. (define (syntax-expression top-level? expression)
  160.   (hook/syntax-expression top-level? expression *syntax-table*))
  161.  
  162. (define hook/syntax-expression)
  163. (define (default/syntax-expression top-level? expression syntax-table)
  164.   (cond
  165.    ((pair? expression)
  166.     (if (not (list? expression))
  167.     (error "syntax-expression: not a valid expression" expression))
  168.     (let ((transform (syntax-table-ref syntax-table (car expression))))
  169.       (if transform
  170.       (if (primitive-syntaxer? transform)
  171.           (transform-apply (primitive-syntaxer/transform transform)
  172.                    (car expression)
  173.                    (cons top-level? (cdr expression)))
  174.           (let ((result
  175.              (fluid-let ((*syntax-top-level?* top-level?))
  176.                (transform-apply transform
  177.                     (car expression)
  178.                     (cdr expression)))))
  179.         (if (syntax-closure? result)
  180.             (syntax-closure/expression result)
  181.             (syntax-expression top-level? result))))
  182.       (make-combination (syntax-subexpression (car expression))
  183.                 (map syntax-subexpression (cdr expression))))))
  184.    ((symbol? expression)
  185.     (make-variable expression))
  186.    (else
  187.     expression)))
  188.  
  189. ;;; Two overlapping kludges here.  This should go away and be replaced
  190. ;;; by a true syntactic closure mechanism like that described by
  191. ;;; Bawden and Rees.
  192.  
  193. (define-integrable (make-syntax-closure expression)
  194.   (cons syntax-closure-tag expression))
  195.  
  196. (define (syntax-closure? expression)
  197.   (and (pair? expression)
  198.        (eq? (car expression) syntax-closure-tag)))
  199.  
  200. (define-integrable (syntax-closure/expression syntax-closure)
  201.   (cdr syntax-closure))
  202.  
  203. (define syntax-closure-tag
  204.   "syntax-closure")
  205.  
  206. (define-integrable (make-primitive-syntaxer expression)
  207.   (cons primitive-syntaxer-tag expression))
  208.  
  209. (define (primitive-syntaxer? expression)
  210.   (and (pair? expression)
  211.        (eq? (car expression) primitive-syntaxer-tag)))
  212.  
  213. (define-integrable (primitive-syntaxer/transform primitive-syntaxer)
  214.   (cdr primitive-syntaxer))
  215.  
  216. (define primitive-syntaxer-tag
  217.   "primitive-syntaxer")
  218.  
  219. (define (transform-apply transform keyword arguments)
  220.   (fluid-let ((*current-keyword* keyword))
  221.     (let ((n-arguments (length arguments)))
  222.       (if (not (procedure-arity-valid? transform n-arguments))
  223.       (syntax-error "incorrect number of subforms" n-arguments)))
  224.     (apply transform arguments)))
  225.  
  226. (define (syntax-error message . irritants)
  227.   (apply error
  228.      (cons
  229.       (string-append "SYNTAX: "
  230.              (if *current-keyword*
  231.                  (string-append (symbol-name *current-keyword*)
  232.                         ": "
  233.                         message)
  234.                  message))
  235.       irritants)))
  236.  
  237. (define (syntax-bindings bindings receiver)
  238.   (if (not (list? bindings))
  239.       (syntax-error "bindings must be a list" bindings)
  240.       (let loop ((bindings bindings) (receiver receiver))
  241.     (cond ((null? bindings)
  242.            (receiver '() '()))
  243.           ((and (pair? (car bindings))
  244.             (symbol? (caar bindings)))
  245.            (loop (cdr bindings)
  246.          (lambda (names values)
  247.            (receiver (cons (caar bindings) names)
  248.                  (cons (expand-binding-value (cdar bindings))
  249.                    values)))))
  250.           (else
  251.            (syntax-error "badly formed binding" (car bindings)))))))
  252.  
  253. ;;;; Expanders
  254.  
  255. (define (expand-access chain cont)
  256.   (if (symbol? (car chain))
  257.       (cont (if (null? (cddr chain))
  258.         (syntax-subexpression (cadr chain))
  259.         (expand-access (cdr chain) make-access))
  260.         (car chain))
  261.       (syntax-error "non-symbolic variable" (car chain))))
  262.  
  263. (define (expand-binding-value rest)
  264.   (cond ((null? rest) (make-unassigned-reference-trap))
  265.     ((null? (cdr rest)) (syntax-subexpression (car rest)))
  266.     (else (syntax-error "too many forms in value" rest))))
  267.  
  268. (define (expand-disjunction forms)
  269.   (if (null? forms)
  270.       #f
  271.       (let process ((forms forms))
  272.     (if (null? (cdr forms))
  273.         (syntax-subexpression (car forms))
  274.         (make-disjunction (syntax-subexpression (car forms))
  275.                   (process (cdr forms)))))))
  276.  
  277. (define (expand-lambda pattern actions receiver)
  278.   ((if (pair? pattern)
  279.        (letrec ((loop
  280.          (lambda (pattern body)
  281.            (if (pair? (car pattern))
  282.                (loop (car pattern)
  283.                  (make-simple-lambda (cdr pattern) body))
  284.                (receiver pattern body)))))
  285.      loop)
  286.        receiver)
  287.    pattern
  288.    (syntax-lambda-body actions)))
  289.  
  290. (define (syntax-lambda-body body)
  291.   (syntax-subsequence
  292.    (if (and (not (null? body))
  293.         (not (null? (cdr body)))
  294.         (string? (car body)))
  295.        (cdr body)            ;discard documentation string.
  296.        body)))
  297.  
  298. ;;;; Basic Syntax
  299.  
  300. (define (syntax/scode-quote top-level? expression)
  301.   top-level?
  302.   (make-quotation (syntax-subexpression expression)))
  303.  
  304. (define (syntax/quote top-level? expression)
  305.   top-level?
  306.   expression)
  307.  
  308. (define (syntax/the-environment top-level?)
  309.   top-level?
  310.   (make-the-environment))
  311.  
  312. (define (syntax/unassigned? top-level? name)
  313.   top-level?
  314.   (make-unassigned? name))
  315.  
  316. (define (syntax/access top-level? . chain)
  317.   top-level?
  318.   (if (not (and (pair? chain) (pair? (cdr chain))))
  319.       (syntax-error "too few forms" chain))
  320.   (expand-access chain make-access))
  321.  
  322. (define (syntax/set! top-level? name . rest)
  323.   top-level?
  324.   ((invert-expression (syntax-subexpression name))
  325.    (expand-binding-value rest)))
  326.  
  327. (define (syntax/define top-level? pattern . rest)
  328.   top-level?
  329.   (let ((make-definition
  330.      (lambda (name value)
  331.        (if (syntax-table-ref *syntax-table* name)
  332.            (syntax-error "redefinition of syntactic keyword" name))
  333.        (make-definition name value))))
  334.     (cond ((symbol? pattern)
  335.        (make-definition
  336.         pattern
  337.         (let ((value
  338.            (expand-binding-value
  339.             (if (and (= (length rest) 2)
  340.                  (string? (cadr rest)))
  341.             (list (car rest))
  342.             rest))))
  343.           (if (lambda? value)
  344.           (lambda-components* value
  345.             (lambda (name required optional rest body)
  346.               (if (eq? name lambda-tag:unnamed)
  347.               (make-lambda* pattern required optional rest body)
  348.               value)))
  349.           value))))
  350.       ((pair? pattern)
  351.        (expand-lambda pattern rest
  352.          (lambda (pattern body)
  353.            (make-definition (car pattern)
  354.                 (make-named-lambda (car pattern) (cdr pattern)
  355.                            body)))))
  356.       (else
  357.        (syntax-error "bad pattern" pattern)))))
  358.  
  359. (define (syntax/begin top-level? . actions)
  360.   (syntax-sequence top-level? actions))
  361.  
  362. (define (syntax/in-package top-level? environment . body)
  363.   top-level?
  364.   (make-in-package (syntax-subexpression environment)
  365.            (make-scode-sequence (syntax-sequence-internal #t body))))
  366.  
  367. (define (syntax/delay top-level? expression)
  368.   top-level?
  369.   (make-delay (syntax-subexpression expression)))
  370.  
  371. ;;;; Conditionals
  372.  
  373. (define (syntax/if top-level? predicate consequent . rest)
  374.   top-level?
  375.   (make-conditional (syntax-subexpression predicate)
  376.             (syntax-subexpression consequent)
  377.             (cond ((null? rest)
  378.                undefined-conditional-branch)
  379.               ((null? (cdr rest))
  380.                (syntax-subexpression (car rest)))
  381.               (else
  382.                (syntax-error "too many forms" (cdr rest))))))
  383.  
  384. (define (syntax/or top-level? . expressions)
  385.   top-level?
  386.   (expand-disjunction expressions))
  387.  
  388. (define (syntax/cond top-level? . clauses)
  389.   top-level?
  390.   (define (loop clause rest)
  391.     (cond ((not (pair? clause))
  392.        (syntax-error "bad COND clause" clause))
  393.       ((eq? (car clause) 'ELSE)
  394.        (if (not (null? rest))
  395.            (syntax-error "ELSE not last clause" rest))
  396.        (syntax-subsequence (cdr clause)))
  397.       ((null? (cdr clause))
  398.        (make-disjunction (syntax-subexpression (car clause)) (next rest)))
  399.       ((and (pair? (cdr clause))
  400.         (eq? (cadr clause) '=>))
  401.        (if (not (and (pair? (cddr clause))
  402.              (null? (cdddr clause))))
  403.            (syntax-error "misformed => clause" clause))
  404.        (let ((predicate (string->uninterned-symbol "PREDICATE")))
  405.          (make-closed-block lambda-tag:let
  406.                 (list predicate)
  407.                 (list (syntax-subexpression (car clause)))
  408.            (let ((predicate (syntax-subexpression predicate)))
  409.          (make-conditional
  410.           predicate
  411.           (make-combination* (syntax-subexpression (caddr clause))
  412.                      predicate)
  413.           (next rest))))))
  414.       (else
  415.        (make-conditional (syntax-subexpression (car clause))
  416.                  (syntax-subsequence (cdr clause))
  417.                  (next rest)))))
  418.  
  419.   (define (next rest)
  420.     (if (null? rest)
  421.     undefined-conditional-branch
  422.     (loop (car rest) (cdr rest))))
  423.  
  424.   (next clauses))
  425.  
  426. ;;;; Procedures
  427.  
  428. (define (syntax/lambda top-level? pattern . body)
  429.   top-level?
  430.   (make-simple-lambda pattern (syntax-lambda-body body)))
  431.  
  432. (define (syntax/named-lambda top-level? pattern . body)
  433.   top-level?
  434.   (expand-lambda pattern body
  435.     (lambda (pattern body)
  436.       (if (pair? pattern)
  437.       (make-named-lambda (car pattern) (cdr pattern) body)
  438.       (syntax-error "illegal named-lambda list" pattern)))))
  439.  
  440. (define (syntax/let top-level? name-or-pattern pattern-or-first . rest)
  441.   top-level?
  442.   (if (symbol? name-or-pattern)
  443.       (syntax-bindings pattern-or-first
  444.     (lambda (names values)
  445.       (if (memq name-or-pattern names)
  446.           (syntax-error "name conflicts with binding"
  447.                 name-or-pattern))
  448.       (make-combination
  449.        (make-letrec (list name-or-pattern)
  450.             (list (make-named-lambda name-or-pattern names
  451.                          (syntax-subsequence rest)))
  452.             (make-variable name-or-pattern))
  453.        values)))
  454.       (syntax-bindings name-or-pattern
  455.     (lambda (names values)
  456.       (make-closed-block
  457.        lambda-tag:let names values
  458.        (syntax-subsequence (cons pattern-or-first rest)))))))
  459.  
  460. ;;;; Syntax Extensions
  461.  
  462. (define (syntax/let-syntax top-level? bindings . body)
  463.   (syntax-bindings bindings
  464.     (lambda (names values)
  465.       (fluid-let ((*syntax-table*
  466.            (syntax-table/extend
  467.             *syntax-table*
  468.             (map (lambda (name value)
  469.                (cons name (syntax-eval value)))
  470.              names
  471.              values))))
  472.     (syntax-sequence top-level? body)))))
  473.  
  474. (define (syntax/using-syntax top-level? table . body)
  475.   (let ((table* (syntax-eval (syntax-subexpression table))))
  476.     (if (not (syntax-table? table*))
  477.     (syntax-error "not a syntax table" table))
  478.     (fluid-let ((*syntax-table* table*))
  479.       (syntax-sequence top-level? body))))
  480.  
  481. (define (syntax/define-syntax top-level? name value)
  482.   top-level?
  483.   (if (not (symbol? name))
  484.       (syntax-error "illegal name" name))
  485.   (syntax-table-define *syntax-table* name
  486.     (syntax-eval (syntax-subexpression value)))
  487.   name)
  488.  
  489. (define (syntax/define-macro top-level? pattern . body)
  490.   top-level?
  491.   (let ((keyword (car pattern)))
  492.     (syntax-table-define *syntax-table* keyword
  493.       (syntax-eval (apply syntax/named-lambda #f pattern body)))
  494.     keyword))
  495.  
  496. (define-integrable (syntax-eval scode)
  497.   (extended-scode-eval scode syntaxer/default-environment))
  498.  
  499. ;;;; FLUID-LET
  500.  
  501. (define (syntax/fluid-let top-level? bindings . body)
  502.   (syntax/fluid-let/current top-level? bindings body))
  503.  
  504. (define syntax/fluid-let/current)
  505.  
  506. (define (set-fluid-let-type! type)
  507.   (set! syntax/fluid-let/current
  508.     (case type
  509.       ((SHALLOW) syntax/fluid-let/shallow)
  510.       ((DEEP) syntax/fluid-let/deep)
  511.       ((COMMON-LISP) syntax/fluid-let/common-lisp)
  512.       (else (error "SET-FLUID-LET-TYPE!: unknown type" type))))
  513.   unspecific)
  514.  
  515. (define (syntax/fluid-let/shallow top-level? bindings body)
  516.   (if (null? bindings)
  517.       (syntax-sequence top-level? body)
  518.       (syntax-fluid-bindings/shallow bindings
  519.     (lambda (names values transfers-in transfers-out)
  520.       (make-closed-block lambda-tag:fluid-let names values
  521.         (make-combination*
  522.          (make-absolute-reference 'SHALLOW-FLUID-BIND)
  523.          (make-thunk (make-scode-sequence transfers-in))
  524.          (make-thunk (syntax-subsequence body))
  525.          (make-thunk (make-scode-sequence transfers-out))))))))
  526.  
  527. (define (syntax/fluid-let/deep top-level? bindings body)
  528.   top-level?
  529.   (syntax/fluid-let/deep* (ucode-primitive add-fluid-binding! 3)
  530.               bindings
  531.               body))
  532.  
  533. (define (syntax/fluid-let/common-lisp top-level? bindings body)
  534.   top-level?
  535.   (syntax/fluid-let/deep* (ucode-primitive make-fluid-binding! 3)
  536.               bindings
  537.               body))
  538.  
  539. (define (syntax/fluid-let/deep* add-fluid-binding! bindings body)
  540.   (make-closed-block lambda-tag:fluid-let '() '()
  541.     (make-combination*
  542.      (ucode-primitive with-saved-fluid-bindings 1)
  543.      (make-thunk
  544.       (make-scode-sequence*
  545.        (make-scode-sequence
  546.     (syntax-fluid-bindings/deep add-fluid-binding! bindings))
  547.        (syntax-subsequence body))))))
  548.  
  549. (define (syntax-fluid-bindings/shallow bindings receiver)
  550.   (if (null? bindings)
  551.       (receiver '() '() '() '())
  552.       (syntax-fluid-bindings/shallow (cdr bindings)
  553.     (lambda (names values transfers-in transfers-out)
  554.       (let ((binding (car bindings)))
  555.         (if (pair? binding)
  556.         (let ((transfer
  557.                (let ((reference (syntax-subexpression (car binding))))
  558.              (let ((assignment (invert-expression reference)))
  559.                (lambda (target source)
  560.                  (make-assignment
  561.                   target
  562.                   (assignment (make-assignment source)))))))
  563.               (value (expand-binding-value (cdr binding)))
  564.               (inside-name
  565.                (string->uninterned-symbol "INSIDE-PLACEHOLDER"))
  566.               (outside-name
  567.                (string->uninterned-symbol "OUTSIDE-PLACEHOLDER")))
  568.           (receiver (cons* inside-name outside-name names)
  569.                 (cons* value (make-unassigned-reference-trap)
  570.                    values)
  571.                 (cons (transfer outside-name inside-name)
  572.                   transfers-in)
  573.                 (cons (transfer inside-name outside-name)
  574.                   transfers-out)))
  575.         (syntax-error "binding not a pair" binding)))))))
  576.  
  577. (define (syntax-fluid-bindings/deep add-fluid-binding! bindings)
  578.   (map (lambda (binding)
  579.      (syntax-fluid-binding/deep add-fluid-binding! binding))
  580.        bindings))
  581.  
  582. (define (syntax-fluid-binding/deep add-fluid-binding! binding)
  583.   (if (pair? binding)
  584.       (let ((name (syntax-subexpression (car binding)))
  585.         (finish
  586.          (lambda (environment name)
  587.            (make-combination* add-fluid-binding!
  588.                   environment
  589.                   name
  590.                   (expand-binding-value (cdr binding))))))
  591.     (cond ((variable? name)
  592.            (finish (make-the-environment) (make-quotation name)))
  593.           ((access? name)
  594.            (access-components name finish))
  595.           (else
  596.            (syntax-error "binding name illegal" (car binding)))))
  597.       (syntax-error "binding not a pair" binding)))
  598.  
  599. ;;;; Extended Assignment Syntax
  600.  
  601. (define (invert-expression target)
  602.   (cond ((variable? target)
  603.      (invert-variable (variable-name target)))
  604.     ((access? target)
  605.      (access-components target invert-access))
  606.     (else
  607.      (syntax-error "bad target" target))))
  608.  
  609. (define ((invert-variable name) value)
  610.   (make-assignment name value))
  611.  
  612. (define ((invert-access environment name) value)
  613.   (make-combination* lexical-assignment environment name value))
  614.  
  615. ;;;; Declarations
  616.  
  617. ;;; All declarations are syntactically checked; the resulting
  618. ;;; DECLARATION objects all contain lists of standard declarations.
  619. ;;; Each standard declaration is a proper list with symbolic keyword.
  620.  
  621. (define (syntax/declare top-level? . declarations)
  622.   top-level?
  623.   (make-block-declaration (map process-declaration declarations)))
  624.  
  625. (define (syntax/local-declare top-level? declarations . body)
  626.   (make-declaration (process-declarations declarations)
  627.             (syntax-sequence top-level? body)))
  628.  
  629. ;;; These two procedures use `error' instead of `syntax-error' because
  630. ;;; they are also called when the syntaxer is not running.
  631.  
  632. (define (process-declarations declarations)
  633.   (if (list? declarations)
  634.       (map process-declaration declarations)
  635.       (error "SYNTAX: Illegal declaration list" declarations)))
  636.  
  637. (define (process-declaration declaration)
  638.   (cond ((symbol? declaration)
  639.      (list declaration))
  640.     ((and (list? declaration)
  641.           (not (null? declaration))
  642.           (symbol? (car declaration)))
  643.      declaration)
  644.     (else
  645.      (error "SYNTAX: Illegal declaration" declaration))))
  646.  
  647. ;;;; SCODE Constructors
  648.  
  649. (define (make-conjunction first second)
  650.   (make-conditional first second #f))
  651.  
  652. (define (make-combination* operator . operands)
  653.   (make-combination operator operands))
  654.  
  655. (define (make-scode-sequence* . operands)
  656.   (make-scode-sequence operands))
  657.  
  658. (define (make-absolute-reference name . rest)
  659.   (let loop ((reference (make-access #f name)) (rest rest))
  660.     (if (null? rest)
  661.     reference
  662.     (loop (make-access reference (car rest)) (cdr rest)))))
  663.  
  664. (define (make-thunk body)
  665.   (make-simple-lambda '() body))
  666.  
  667. (define (make-simple-lambda pattern body)
  668.   (make-named-lambda lambda-tag:unnamed pattern body))
  669.  
  670. (define (make-named-lambda name pattern body)
  671.   (if (not (symbol? name))
  672.       (syntax-error "name of lambda expression must be a symbol" name))
  673.   (parse-lambda-list pattern
  674.     (lambda (required optional rest)
  675.       (internal-make-lambda name required optional rest body))))
  676.  
  677. (define (make-closed-block tag names values body)
  678.   (make-combination (internal-make-lambda tag names '() #f body) values))
  679.  
  680. (define (make-letrec names values body)
  681.   (make-closed-block lambda-tag:let '() '()
  682.              (make-scode-sequence
  683.               (append! (map make-definition names values)
  684.                    (list body)))))
  685.  
  686. (define-integrable lambda-tag:unnamed
  687.   ((ucode-primitive string->symbol) "#[unnamed-procedure]"))
  688.  
  689. (define-integrable lambda-tag:let
  690.   ((ucode-primitive string->symbol) "#[let-procedure]"))
  691.  
  692. (define-integrable lambda-tag:fluid-let
  693.   ((ucode-primitive string->symbol) "#[fluid-let-procedure]"))
  694.  
  695. (define-integrable lambda-tag:make-environment
  696.   ((ucode-primitive string->symbol) "#[make-environment]"))
  697.  
  698. ;;;; Lambda List Parser
  699.  
  700. (define (parse-lambda-list lambda-list receiver)
  701.   (let ((required (list '()))
  702.     (optional (list '())))
  703.     (define (parse-parameters cell pattern)
  704.       (let loop ((pattern pattern))
  705.     (cond ((null? pattern) (finish #f))
  706.           ((symbol? pattern) (finish pattern))
  707.           ((not (pair? pattern)) (bad-lambda-list pattern))
  708.           ((eq? (car pattern) lambda-rest-tag)
  709.            (if (and (pair? (cdr pattern)) (null? (cddr pattern)))
  710.            (cond ((symbol? (cadr pattern)) (finish (cadr pattern)))
  711.              ((and (pair? (cadr pattern))
  712.                    (symbol? (caadr pattern)))
  713.               (finish (caadr pattern)))
  714.              (else (bad-lambda-list (cdr pattern))))
  715.            (bad-lambda-list (cdr pattern))))
  716.           ((eq? (car pattern) lambda-optional-tag)
  717.            (if (eq? cell required)
  718.            (parse-parameters optional (cdr pattern))
  719.            (bad-lambda-list pattern)))
  720.           ((symbol? (car pattern))
  721.            (set-car! cell (cons (car pattern) (car cell)))
  722.            (loop (cdr pattern)))
  723.           ((and (pair? (car pattern)) (symbol? (caar pattern)))
  724.            (set-car! cell (cons (caar pattern) (car cell)))
  725.            (loop (cdr pattern)))
  726.           (else (bad-lambda-list pattern)))))
  727.  
  728.     (define (finish rest)
  729.       (let ((required (reverse! (car required)))
  730.         (optional (reverse! (car optional))))
  731.     (do ((parameters
  732.           (append required optional (if rest (list rest) '()))
  733.           (cdr parameters)))
  734.         ((null? parameters))
  735.       (if (memq (car parameters) (cdr parameters))
  736.           (syntax-error "lambda list has duplicate parameter:"
  737.                 (car parameters)
  738.                 (error-irritant/noise " in")
  739.                 lambda-list)))
  740.     (receiver required optional rest)))
  741.  
  742.     (define (bad-lambda-list pattern)
  743.       (syntax-error "illegally-formed lambda list" pattern))
  744.  
  745.     (parse-parameters required lambda-list)))
  746.  
  747. ;;;; Scan Defines
  748.  
  749. (define (make-sequence/scan actions)
  750.   (scan-defines (make-sequence actions)
  751.     make-open-block))
  752.  
  753. (define (make-lambda/no-scan name required optional rest body)
  754.   (make-lambda name required optional rest '() '() body))
  755.  
  756. (define (make-lambda/scan name required optional rest body)
  757.   (make-lambda* name required optional rest body))
  758.  
  759. (define make-scode-sequence)
  760. (define internal-make-lambda)
  761.  
  762. (define (enable-scan-defines!)
  763.   (set! make-scode-sequence make-sequence/scan)
  764.   (set! internal-make-lambda make-lambda/scan)
  765.   unspecific)
  766.  
  767. (define (disable-scan-defines!)
  768.   (set! make-scode-sequence make-sequence)
  769.   (set! internal-make-lambda make-lambda/no-scan)
  770.   unspecific)