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 / unsyn.scm < prev    next >
Text File  |  2001-03-21  |  19KB  |  567 lines
  1. #| -*-Scheme-*-
  2.  
  3. $Id: unsyn.scm,v 14.21 2001/03/21 19:15:29 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. ;;;; UNSYNTAX: SCode -> S-Expression
  24. ;;; package: (runtime unsyntaxer)
  25.  
  26. (declare (usual-integrations))
  27.  
  28. (define (initialize-package!)
  29.   (set! unsyntaxer/scode-walker
  30.     (make-scode-walker unsyntax-constant
  31.                `((ACCESS ,unsyntax-ACCESS-object)
  32.                  (ASSIGNMENT ,unsyntax-ASSIGNMENT-object)
  33.                  (COMBINATION ,unsyntax-COMBINATION-object)
  34.                  (COMMENT ,unsyntax-COMMENT-object)
  35.                  (CONDITIONAL ,unsyntax-CONDITIONAL-object)
  36.                  (DECLARATION ,unsyntax-DECLARATION-object)
  37.                  (DEFINITION ,unsyntax-DEFINITION-object)
  38.                  (DELAY ,unsyntax-DELAY-object)
  39.                  (DISJUNCTION ,unsyntax-DISJUNCTION-object)
  40.                  (IN-PACKAGE ,unsyntax-IN-PACKAGE-object)
  41.                  (LAMBDA ,unsyntax-LAMBDA-object)
  42.                  (OPEN-BLOCK ,unsyntax-OPEN-BLOCK-object)
  43.                  (QUOTATION ,unsyntax-QUOTATION)
  44.                  (SEQUENCE ,unsyntax-SEQUENCE-object)
  45.                  (THE-ENVIRONMENT ,unsyntax-THE-ENVIRONMENT-object)
  46.                  (UNASSIGNED? ,unsyntax-UNASSIGNED?-object)
  47.                  (VARIABLE ,unsyntax-VARIABLE-object))))
  48.   unspecific)
  49.  
  50. (define unsyntaxer:macroize?
  51.   true)
  52.  
  53. (define unsyntaxer:show-comments?
  54.   false)
  55.  
  56. (define unsyntaxer:elide-global-accesses?
  57.   false)
  58.  
  59. (define substitutions '())
  60.  
  61. (define (unsyntax-with-substitutions scode alist)
  62.   (if (not (alist? alist))
  63.       (error:wrong-type-argument alist "alist" 'UNSYNTAX-WITH-SUBSTITUTIONS))
  64.   (fluid-let ((substitutions alist))
  65.     (unsyntax scode)))
  66.  
  67. (define (maybe-substitute object action)
  68.   (let ((association (has-substitution? object)))
  69.     (if association
  70.     (cdr association)
  71.     (action object))))
  72.  
  73. (define-integrable (has-substitution? object)
  74.   (and (not (null? substitutions))
  75.        (assq object substitutions)))
  76.  
  77. (define bound (list #F '()))
  78.  
  79. (define (with-bindings required optional rest action argument)
  80.   (if (and unsyntaxer:elide-global-accesses?
  81.        unsyntaxer:macroize?)
  82.       (let* ((bound bound)
  83.          (old   (cdr bound)))
  84.     (set-cdr! bound
  85.           (append (if rest (list rest) '()) required optional old))
  86.     (let ((value (action argument)))
  87.       (set-cdr! bound old)
  88.       value))
  89.       (action argument)))
  90.        
  91. (define (unsyntax scode)
  92.   (fluid-let ((bound (list #F '())))
  93.     (unsyntax-object (if (procedure? scode) (procedure-lambda scode) scode))))
  94.  
  95. (define (unsyntax-object object)
  96.   (maybe-substitute
  97.    object
  98.    (lambda (object) ((scode-walk unsyntaxer/scode-walker object) object))))
  99.  
  100. (define unsyntaxer/scode-walker)
  101.  
  102. (define (unsyntax-objects objects)
  103.   (if (null? objects)
  104.       '()
  105.       (cons (unsyntax-object (car objects))
  106.         (unsyntax-objects (cdr objects)))))
  107.  
  108. (define (unsyntax-error keyword message . irritants)
  109.   (apply error
  110.      (cons (string-append "UNSYNTAX: " (symbol-name keyword) ": "
  111.                   message)
  112.            irritants)))
  113.  
  114. ;;;; Unsyntax Quanta
  115.  
  116. (define (unsyntax-constant object)
  117.   (cond (;; R4RS self-evaluating objects:
  118.      (or (boolean? object) (number? object) (char? object) (string? object))
  119.      object)
  120.     (;; R4RS quoted data (in addition to above)
  121.      (or (pair? object) (null? object) (symbol? object) (vector? object))
  122.      `(QUOTE ,object))
  123.     ((compiled-expression? object)
  124.      (let ((scode (compiled-expression/scode object)))
  125.        (if (eq? scode object)
  126.            `(SCODE-QUOTE ,object)
  127.            (unsyntax-object scode))))
  128.     (else
  129.      object)))
  130.  
  131. (define (unsyntax-QUOTATION quotation)
  132.   `(SCODE-QUOTE ,(unsyntax-object (quotation-expression quotation))))
  133.  
  134. (define (unsyntax-VARIABLE-object object)
  135.   (variable-name object))
  136.  
  137. (define (unsyntax-ACCESS-object object)
  138.   (or (and unsyntaxer:elide-global-accesses?
  139.        unsyntaxer:macroize?
  140.        (access-components object
  141.          (lambda (environment name)
  142.            (and (eq? environment system-global-environment)
  143.             (not (memq name (cdr bound)))
  144.             name))))
  145.       `(ACCESS ,@(unexpand-access object))))
  146.  
  147. (define (unexpand-access object)
  148.   (let loop ((object object) (separate? true))
  149.     (if (and separate?
  150.          (access? object)
  151.          (not (has-substitution? object)))
  152.     (access-components object
  153.       (lambda (environment name)
  154.         `(,name ,@(loop environment (eq? #t unsyntaxer:macroize?)))))
  155.     `(,(unsyntax-object object)))))
  156.  
  157. (define (unsyntax-DEFINITION-object definition)
  158.   (definition-components definition unexpand-definition))
  159.  
  160. (define (unsyntax-ASSIGNMENT-object assignment)
  161.   (assignment-components assignment
  162.     (lambda (name value)
  163.       `(SET! ,name ,@(unexpand-binding-value value)))))
  164.  
  165. (define (unexpand-definition name value)
  166.   (if (and (eq? #t unsyntaxer:macroize?)
  167.        (lambda? value)
  168.        (not (has-substitution? value)))
  169.       (lambda-components** value
  170.     (lambda (lambda-name required optional rest body)
  171.       (if (eq? lambda-name name)
  172.           `(DEFINE (,name . ,(lambda-list required optional rest '()))
  173.          ,@(with-bindings required optional rest
  174.                   unsyntax-sequence body))
  175.           `(DEFINE ,name ,@(unexpand-binding-value value)))))
  176.       `(DEFINE ,name ,@(unexpand-binding-value value))))
  177.  
  178. (define (unexpand-binding-value value)
  179.   (if (unassigned-reference-trap? value)
  180.       '()
  181.       `(,(unsyntax-object value))))
  182.  
  183. (define (unsyntax-UNASSIGNED?-object object)
  184.   `(UNASSIGNED? ,(unassigned?-name object)))
  185.  
  186. (define (unsyntax-COMMENT-object comment)
  187.   (let ((expression (unsyntax-object (comment-expression comment))))
  188.     (if unsyntaxer:show-comments?
  189.     `(COMMENT ,(comment-text comment) ,expression)
  190.     expression)))
  191.  
  192. (define (unsyntax-DECLARATION-object declaration)
  193.   (declaration-components declaration
  194.     (lambda (text expression)
  195.       `(LOCAL-DECLARE ,text ,(unsyntax-object expression)))))
  196.  
  197. (define (unsyntax-SEQUENCE-object seq)
  198.   `(BEGIN ,@(unsyntax-sequence-actions seq)))
  199.  
  200. (define (unsyntax-sequence seq)
  201.   (if (sequence? seq)
  202.       (if (eq? #t unsyntaxer:macroize?)
  203.       (unsyntax-sequence-actions seq)
  204.       `((BEGIN ,@(unsyntax-sequence-actions seq))))
  205.       (list (unsyntax-object seq))))
  206.  
  207. (define (unsyntax-sequence-actions seq)
  208.   (let ((actions (sequence-immediate-actions seq)))
  209.     (let loop ((actions actions))
  210.       (if (null? actions)
  211.       '()
  212.       (let ((substitution (has-substitution? (car actions))))
  213.         (cond (substitution
  214.            (cons (cdr substitution)
  215.              (loop (cdr actions))))
  216.           ((and (eq? #t unsyntaxer:macroize?)
  217.             (sequence? (car actions)))
  218.            (append (unsyntax-sequence-actions (car actions))
  219.                (loop (cdr actions))))
  220.           (else
  221.            (cons (unsyntax-object (car actions))
  222.              (loop (cdr actions))))))))))
  223.  
  224. (define (unsyntax-OPEN-BLOCK-object open-block)
  225.   (if (eq? #t unsyntaxer:macroize?)
  226.       (open-block-components open-block
  227.     (lambda (auxiliary declarations expression)
  228.       `(OPEN-BLOCK ,auxiliary
  229.                ,declarations
  230.                ,@(unsyntax-sequence expression))))
  231.       (unsyntax-SEQUENCE-object open-block)))
  232.  
  233. (define (unsyntax-DELAY-object object)
  234.   `(DELAY ,(unsyntax-object (delay-expression object))))
  235.  
  236. (define (unsyntax-IN-PACKAGE-object object)
  237.   (in-package-components object
  238.     (lambda (environment expression)
  239.       `(IN-PACKAGE ,(unsyntax-object environment)
  240.      ,@(unsyntax-sequence expression)))))
  241.  
  242. (define (unsyntax-THE-ENVIRONMENT-object object)
  243.   object
  244.   `(THE-ENVIRONMENT))
  245.  
  246. (define (unsyntax-DISJUNCTION-object object)
  247.   `(OR ,@(disjunction-components object
  248.        (if (eq? #t unsyntaxer:macroize?)
  249.            unexpand-disjunction
  250.            (lambda (predicate alternative)
  251.          (list (unsyntax-object predicate)
  252.                (unsyntax-object alternative)))))))       
  253.  
  254. (define (unexpand-disjunction predicate alternative)
  255.   `(,(unsyntax-object predicate)
  256.     ,@(if (disjunction? alternative)
  257.       (disjunction-components alternative unexpand-disjunction)
  258.       `(,(unsyntax-object alternative)))))
  259.  
  260. (define (unsyntax-CONDITIONAL-object conditional)
  261.   (conditional-components conditional
  262.     (if (eq? #t unsyntaxer:macroize?)
  263.     unsyntax-conditional
  264.     unsyntax-conditional/default)))
  265.  
  266. (define (unsyntax-conditional/default predicate consequent alternative)
  267.   `(IF ,(unsyntax-object predicate)
  268.        ,(unsyntax-object consequent)
  269.        ,(unsyntax-object alternative)))
  270.  
  271. (define (unsyntax-conditional predicate consequent alternative)
  272.   (cond ((false? alternative)
  273.      `(AND ,@(unexpand-conjunction predicate consequent)))
  274.     ((eq? alternative undefined-conditional-branch)
  275.      `(IF ,(unsyntax-object predicate)
  276.           ,(unsyntax-object consequent)))
  277.     ((eq? consequent undefined-conditional-branch)
  278.      `(IF (,not ,(unsyntax-object predicate))
  279.           ,(unsyntax-object alternative)))
  280.     ((and (conditional? alternative)
  281.           (not (has-substitution? alternative)))
  282.      `(COND ,@(unsyntax-cond-conditional predicate
  283.                          consequent
  284.                          alternative)))
  285.     (else
  286.      (unsyntax-conditional/default predicate consequent alternative))))
  287.  
  288. (define (unsyntax-cond-conditional predicate consequent alternative)
  289.   `((,(unsyntax-object predicate) ,@(unsyntax-sequence consequent))
  290.     ,@(unsyntax-cond-alternative alternative)))
  291.  
  292. (define (unsyntax-cond-disjunction predicate alternative)
  293.   `((,(unsyntax-object predicate))
  294.     ,@(unsyntax-cond-alternative alternative)))
  295.  
  296. (define (unsyntax-cond-alternative alternative)
  297.   (cond ((eq? alternative undefined-conditional-branch)
  298.      '())
  299.     ((has-substitution? alternative)
  300.      =>
  301.      (lambda (substitution)
  302.        `((ELSE ,substitution))))
  303.     ((disjunction? alternative)
  304.      (disjunction-components alternative unsyntax-cond-disjunction))
  305.     ((conditional? alternative)
  306.      (conditional-components alternative unsyntax-cond-conditional))
  307.     (else
  308.      `((ELSE ,@(unsyntax-sequence alternative))))))
  309.  
  310. (define (unexpand-conjunction predicate consequent)
  311.   (if (and (conditional? consequent)
  312.        (not (has-substitution? consequent)))
  313.       `(,(unsyntax-object predicate)
  314.     ,@(conditional-components consequent
  315.         (lambda (predicate consequent alternative)
  316.           (if (false? alternative)
  317.           (unexpand-conjunction predicate consequent)
  318.           `(,(unsyntax-conditional predicate
  319.                        consequent
  320.                        alternative))))))
  321.       `(,(unsyntax-object predicate) ,(unsyntax-object consequent))))
  322.  
  323. ;;;; Lambdas
  324.  
  325. (define (unsyntax-LAMBDA-object expression)
  326.   (if unsyntaxer:macroize?
  327.       (lambda-components** expression
  328.     (lambda (name required optional rest body)
  329.       (collect-lambda name
  330.               (lambda-list required optional rest '())
  331.               (with-bindings required optional rest
  332.                      unsyntax-sequence body))))
  333.       (lambda-components expression
  334.     (lambda (name required optional rest auxiliary declarations body)
  335.       (collect-lambda name
  336.               (lambda-list required optional rest auxiliary)
  337.               (let ((body (unsyntax-sequence body)))
  338.                 (if (null? declarations)
  339.                 body
  340.                 `((DECLARE ,@declarations)
  341.                   ,@body))))))))
  342.  
  343. (define (collect-lambda name bvl body)
  344.   (if (eq? name lambda-tag:unnamed)
  345.       `(LAMBDA ,bvl ,@body)
  346.       `(NAMED-LAMBDA (,name . ,bvl) ,@body)))
  347.  
  348. (define (unsyntax-lambda-list expression)
  349.   (if (not (lambda? expression))
  350.       (error:wrong-type-argument expression "SCode lambda"
  351.                  'UNSYNTAX-LAMBDA-LIST))
  352.   (lambda-components** expression
  353.     (lambda (name required optional rest body)
  354.       name body
  355.       (lambda-list required optional rest '()))))
  356.  
  357. (define (lambda-list required optional rest auxiliary)
  358.   (let ((optional (if (null? optional)
  359.               '()
  360.               (cons lambda-optional-tag optional)))
  361.     (rest (cond ((not rest) '())
  362.             ((null? auxiliary) rest)
  363.             (else (list lambda-rest-tag rest)))))
  364.     (if (null? auxiliary)
  365.     `(,@required ,@optional . ,rest)
  366.     `(,@required ,@optional ,@rest ,lambda-auxiliary-tag ,@auxiliary))))
  367.  
  368. (define (lambda-components** expression receiver)
  369.   (lambda-components expression
  370.     (lambda (name required optional rest auxiliary declarations body)
  371.       (define (bind-auxilliaries aux body*)
  372.     (with-bindings aux '() #F
  373.                (lambda (body*)
  374.                  (receiver name required optional rest body*))
  375.                body*))
  376.       (if (and (null? auxiliary)
  377.            (null? declarations))
  378.       (scan-defines body
  379.             (lambda (internal-defines declarations* body*)
  380.               declarations* body*
  381.               (bind-auxilliaries internal-defines body)))
  382.       (bind-auxilliaries auxiliary
  383.                  (unscan-defines auxiliary declarations body))))))
  384.  
  385. ;;;; Combinations
  386.  
  387. (define (unsyntax-COMBINATION-object combination)
  388.   (rewrite-named-let
  389.    (combination-components combination
  390.      (lambda (operator operands)
  391.        (let ((ordinary-combination
  392.           (lambda ()
  393.         `(,(unsyntax-object operator) ,@(unsyntax-objects operands)))))
  394.      (cond ((or (not (eq? #t unsyntaxer:macroize?))
  395.             (has-substitution? operator))
  396.         (ordinary-combination))
  397.            ((and (or (eq? operator cons)
  398.              (absolute-reference-to? operator 'CONS))
  399.              (= (length operands) 2)
  400.              (delay? (cadr operands))
  401.              (not (has-substitution? (cadr operands))))
  402.         `(CONS-STREAM ,(unsyntax-object (car operands))
  403.                   ,(unsyntax-object
  404.                 (delay-expression (cadr operands)))))
  405.            ((lambda? operator)
  406.         (lambda-components** operator
  407.           (lambda (name required optional rest body)
  408.             (if (and (null? optional)
  409.                  (false? rest)
  410.                  (= (length required) (length operands)))
  411.             (cond ((or (eq? name lambda-tag:unnamed)
  412.                    (eq? name lambda-tag:let))
  413.                    `(LET ,(unsyntax-let-bindings required operands)
  414.                   ,@(with-bindings required '() #F
  415.                            unsyntax-sequence body)))
  416.                   ((eq? name lambda-tag:fluid-let)
  417.                    (unsyntax/fluid-let required
  418.                            operands
  419.                            body
  420.                            ordinary-combination))
  421.                   ((and (eq? name lambda-tag:make-environment)
  422.                     (the-environment?
  423.                      (car
  424.                       (last-pair (sequence-actions body)))))
  425.                    (with-bindings
  426.                 required '() #F
  427.                 (lambda (body)
  428.                   `(MAKE-ENVIRONMENT
  429.                      ,@(unsyntax-objects
  430.                     (except-last-pair
  431.                      (sequence-actions body)))))
  432.                 body))
  433.                   (else (ordinary-combination)))
  434.             (ordinary-combination)))))
  435.            (else
  436.         (ordinary-combination))))))))
  437.  
  438. (define (unsyntax-let-bindings names values)
  439.   (map unsyntax-let-binding names values))
  440.  
  441. (define (unsyntax-let-binding name value)
  442.   `(,name ,@(unexpand-binding-value value)))
  443.  
  444. (define (rewrite-named-let expression)
  445.   (if (and (pair? expression)
  446.        (let ((expression (car expression)))
  447.          (and (list? expression)
  448.           (= 4 (length expression))
  449.           (eq? 'LET (car expression))
  450.           (eq? '() (cadr expression))
  451.           (symbol? (cadddr expression))
  452.           (let ((definition (caddr expression)))
  453.             (and (pair? definition)
  454.              (eq? 'DEFINE (car definition))
  455.              (pair? (cadr definition))
  456.              (eq? (caadr definition) (cadddr expression))
  457.              (list? (cdadr definition))
  458.              (for-all? (cdadr definition) symbol?))))))
  459.       `(LET ,(cadddr (car expression))
  460.      ,(map (lambda (name value)
  461.          `(,name
  462.            ,@(if (unassigned-reference-trap? value)
  463.              '()
  464.              `(,value))))
  465.            (cdadr (caddr (car expression)))
  466.            (cdr expression))
  467.      ,@(cddr (caddr (car expression))))
  468.       expression))
  469.  
  470. (define (unsyntax/fluid-let names values body if-malformed)
  471.   (combination-components body
  472.     (lambda (operator operands)
  473.       ;; `fluid-let' expressions are complicated.  Rather than scan
  474.       ;; the entire expresion to find out if it has any substitutable
  475.       ;; subparts, we just treat it as malformed if there are active
  476.       ;; substitutions.
  477.       (cond ((not (null? substitutions))
  478.          (if-malformed))
  479.         ((and (or (absolute-reference-to? operator 'SHALLOW-FLUID-BIND)
  480.               (and (variable? operator)
  481.                (eq? (variable-name operator) 'SHALLOW-FLUID-BIND)))
  482.           (pair? operands)
  483.           (lambda? (car operands))
  484.           (pair? (cdr operands))
  485.           (lambda? (cadr operands))
  486.           (pair? (cddr operands))
  487.           (lambda? (caddr operands))
  488.           (null? (cdddr operands)))
  489.          (unsyntax/fluid-let/shallow names values operands))
  490.         ((and (eq? operator (ucode-primitive with-saved-fluid-bindings 1))
  491.           (null? names)
  492.           (null? values)
  493.           (not (null? operands))
  494.           (lambda? (car operands))
  495.           (null? (cdr operands)))
  496.          (unsyntax/fluid-let/deep (car operands)))
  497.         (else
  498.          (if-malformed))))))
  499.  
  500. (define (unsyntax/fluid-let/shallow names values operands)
  501.   names
  502.   `(FLUID-LET ,(unsyntax-let-bindings
  503.         (map extract-transfer-var
  504.              (sequence-actions (lambda-body (car operands))))
  505.         (let every-other ((values values))
  506.           (if (null? values)
  507.               '()
  508.               (cons (car values) (every-other (cddr values))))))
  509.      ,@(lambda-components** (cadr operands)
  510.      (lambda (name required optional rest body)
  511.        name required optional rest
  512.        (with-bindings required optional rest
  513.               unsyntax-sequence body)))))
  514.  
  515. (define (extract-transfer-var assignment)
  516.   (assignment-components assignment
  517.     (lambda (name value)
  518.       name
  519.       (cond ((assignment? value)
  520.          (assignment-components value (lambda (name value) value name)))
  521.         ((combination? value)
  522.          (combination-components value
  523.            (lambda (operator operands)
  524.          (cond ((eq? operator lexical-assignment)
  525.             `(ACCESS ,(cadr operands)
  526.                  ,@(unexpand-access (car operands))))
  527.                (else
  528.             (unsyntax-error 'FLUID-LET
  529.                     "Unknown SCODE form"
  530.                     assignment))))))
  531.         (else
  532.          (unsyntax-error 'FLUID-LET "Unknown SCODE form" assignment))))))
  533.  
  534. (define (unsyntax/fluid-let/deep expression)
  535.   (let ((body (lambda-body expression)))
  536.     (let loop
  537.     ((actions (sequence-actions body))
  538.      (receiver
  539.       (lambda (bindings body)
  540.         `(FLUID-LET ,bindings ,@body))))
  541.       (let ((action (car actions)))
  542.     (if (and (combination? action)
  543.          (or (eq? (combination-operator action)
  544.               (ucode-primitive add-fluid-binding! 3))
  545.              (eq? (combination-operator action)
  546.               (ucode-primitive make-fluid-binding! 3))))
  547.         (loop (cdr actions)
  548.           (lambda (bindings body)
  549.         (receiver (cons (unsyntax-fluid-assignment action) bindings)
  550.               body)))
  551.         (receiver '() (unsyntax-objects actions)))))))
  552.  
  553. (define (unsyntax-fluid-assignment combination)
  554.   (let ((operands (combination-operands combination)))
  555.     (let ((environment (car operands))
  556.       (name (cadr operands))
  557.       (value (caddr operands)))
  558.       (cond ((symbol? name)
  559.          `((ACCESS ,name ,(unsyntax-object environment))
  560.            ,(unsyntax-object value)))
  561.         ((quotation? name)
  562.          (let ((variable (quotation-expression name)))
  563.            (if (variable? variable)
  564.            `(,(variable-name variable) ,(unsyntax-object value))
  565.            (unsyntax-error 'FLUID-LET "unexpected name" name))))
  566.         (else
  567.          (unsyntax-error 'FLUID-LET "unexpected name" name))))))