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 / compiler / base / pmerly.scm < prev    next >
Text File  |  1999-01-02  |  23KB  |  716 lines
  1. #| -*-Scheme-*-
  2.  
  3. $Id: pmerly.scm,v 1.9 1999/01/02 06:06:43 cph Exp $
  4.  
  5. Copyright (c) 1988, 1999 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., 675 Mass Ave, Cambridge, MA 02139, USA.
  20. |#
  21.  
  22. ;;;; Very Simple Pattern Matcher: Early rule compilation and lookup
  23.  
  24. (declare (usual-integrations))
  25.  
  26. ;;;; Database construction
  27.  
  28. (define (early-make-rule pattern variables body)
  29.   (list pattern variables body))
  30.  
  31. (define (early-parse-rule pattern receiver)
  32.   (extract-variables pattern receiver))
  33.  
  34. (define (extract-variables pattern receiver)
  35.   (cond ((not (pair? pattern))
  36.      (receiver pattern '()))
  37.     ((eq? (car pattern) '@)
  38.      (error "early-parse-rule: ?@ is not an implemented pattern"
  39.         pattern))
  40.     ((eq? (car pattern) '?)
  41.      (receiver (make-pattern-variable (cadr pattern))
  42.            (list (cons (cadr pattern)
  43.                    (if (null? (cddr pattern))
  44.                    '()
  45.                    (list (cons (car pattern)
  46.                            (cddr pattern))))))))
  47.     (else
  48.      (extract-variables (car pattern)
  49.       (lambda (car-pattern car-variables)
  50.         (extract-variables (cdr pattern)
  51.          (lambda (cdr-pattern cdr-variables)
  52.            (receiver (cons car-pattern cdr-pattern)
  53.              (merge-variables-lists car-variables
  54.                         cdr-variables)))))))))
  55.  
  56. (define (merge-variables-lists x y)
  57.   (cond ((null? x) y)
  58.     ((null? y) x)
  59.     (else
  60.      (let ((entry (assq (caar x) y)))
  61.        (if entry
  62.            #|
  63.            (cons (append! (car x) (cdr entry))
  64.              (merge-variables-lists (cdr x)
  65.                         (delq! entry y)))
  66.            |#
  67.            (error "early-parse-rule: repeated variables not supported"
  68.               (list (caar x) entry))
  69.            (cons (car x)
  70.              (merge-variables-lists (cdr x)
  71.                         y)))))))
  72.  
  73. ;;;; Early rule processing and code compilation
  74.  
  75. (define (early-pattern-lookup rules instance #!optional transformers unparsed
  76.                   receiver limit)
  77.   (if (default-object? limit) (set! limit *rule-limit*))
  78.   (if (or (default-object? receiver) (null? receiver))
  79.       (set! receiver
  80.         (lambda (result code)
  81.           (cond ((false? result)
  82.              (error "early-pattern-lookup: No pattern matches"
  83.                 instance))
  84.             ((eq? result 'TOO-MANY)
  85.              (error "early-pattern-lookup: Too many patterns match"
  86.                 limit instance))
  87.             (else code)))))
  88.   (parse-instance instance
  89.    (lambda (expression bindings)
  90.      (apply (lambda (result program)
  91.           (receiver result
  92.             (if (or (eq? result true) (eq? result 'MAYBE))
  93.                 (scode/make-block bindings '() program)
  94.                 false)))
  95.         (fluid-let ((*rule-limit* limit)
  96.             (*transformers* (if (default-object? transformers)
  97.                         '()
  98.                         transformers)))
  99.           (try-rules rules expression
  100.              (scode/make-error-combination
  101.               "early-pattern-lookup: No pattern matches"
  102.               (if (or (default-object? unparsed) (null? unparsed))
  103.                   (scode/make-constant instance)
  104.                   unparsed))
  105.              list))))))
  106.  
  107. (define (parse-instance instance receiver)
  108.   (cond ((not (pair? instance))
  109.      (receiver instance '()))
  110.     ((eq? (car instance) 'UNQUOTE)
  111.      ;; Shadowing may not permit the optimization below.
  112.      ;; I think the code is being careful, but...
  113.      (let ((expression (cadr instance)))
  114.        (if (scode/variable? expression)
  115.            (receiver (make-evaluation expression) '())
  116.            (let ((var (make-variable-name 'RESULT)))
  117.          (receiver (make-evaluation (scode/make-variable var))
  118.                (list (scode/make-binding var expression)))))))
  119.     ((eq? (car instance) 'UNQUOTE-SPLICING)
  120.      (error "parse-instance: unquote-splicing not supported" instance))
  121.     (else (parse-instance (car instance)
  122.            (lambda (instance-car car-bindings)
  123.          (parse-instance (cdr instance)
  124.           (lambda (instance-cdr cdr-bindings)
  125.             (receiver (cons instance-car instance-cdr)
  126.                   (append car-bindings cdr-bindings)))))))))
  127.  
  128. ;;;; Find matching rules and collect them
  129.  
  130. (define *rule-limit* '())
  131.  
  132. (define (try-rules rules expression null-form receiver)
  133.   (define (loop rules null-form bindings nrules)
  134.     (cond ((and (not (null? *rule-limit*))
  135.         (> nrules *rule-limit*))
  136.        (receiver 'TOO-MANY false))
  137.       ((not (null? rules))
  138.        (try-rule (car rules)
  139.              expression
  140.              null-form
  141.         (lambda (result code)
  142.           (cond ((false? result)
  143.              (loop (cdr rules) null-form bindings nrules))
  144.             ((eq? result 'MAYBE)
  145.              (let ((var (make-variable-name 'TRY-NEXT-RULE-)))
  146.                (loop (cdr rules)
  147.                  (scode/make-combination (scode/make-variable var)
  148.                              '())
  149.                  (cons (cons var code)
  150.                    bindings)
  151.                  (1+ nrules))))
  152.             (else (receiver true code))))))
  153.       ((null? bindings)
  154.        (receiver false null-form))
  155.       ((null? (cdr bindings))
  156.        (receiver 'MAYBE (cdar bindings)))
  157.       (else
  158.        (receiver 'MAYBE
  159.              (scode/make-letrec
  160.               (map (lambda (pair)
  161.                  (scode/make-binding
  162.                   (car pair)
  163.                   (scode/make-thunk (cdr pair))))
  164.                bindings)
  165.               null-form)))))
  166.   (loop rules null-form '() 0))
  167.  
  168. ;;;; Match one rule
  169.  
  170. (define (try-rule rule expression null-form continuation)
  171.   (define (try pattern expression receiver)
  172.     (cond ((evaluation? expression)
  173.        (receiver '() (list (cons expression pattern))))
  174.       ((not (pair? pattern))
  175.        (if (eqv? pattern expression)
  176.            (receiver '() '())
  177.            (continuation false null-form)))
  178.       ((pattern-variable? pattern)
  179.        (receiver (list (cons (pattern-variable-name pattern) expression))
  180.              '()))
  181.       ((not (pair? expression))
  182.        (continuation false null-form))
  183.       (else
  184.        (try (car pattern)
  185.         (car expression)
  186.         (lambda (car-bindings car-evaluations)
  187.           (try (cdr pattern)
  188.                (cdr expression)
  189.                (lambda (cdr-bindings cdr-evaluations)
  190.              (receiver (append car-bindings cdr-bindings)
  191.                    (append car-evaluations
  192.                        cdr-evaluations)))))))))
  193.   (try (car rule)
  194.        expression
  195.        (lambda (bindings evaluations)
  196.      (match-bind bindings evaluations
  197.              (cadr rule) (caddr rule)
  198.              null-form continuation))))
  199.  
  200. ;;;; Early rule processing
  201.  
  202. (define (match-bind bindings evaluations variables body null-form receiver)
  203.   (process-evaluations evaluations true bindings
  204.    (lambda (outer-test bindings)
  205.      (define (find-early-bindings original test bindings)
  206.        (if (null? original)
  207.        (generate-match-code outer-test test
  208.                 bindings body
  209.                 null-form receiver)
  210.        (bind-variable-early (car original)
  211.                 variables
  212.         (lambda (var-test var-bindings)
  213.           (if (false? var-test)
  214.           (receiver false null-form)
  215.           (find-early-bindings (cdr original)
  216.                        (scode/merge-tests var-test test)
  217.                        (append var-bindings bindings)))))))
  218.      (if (false? outer-test)
  219.      (receiver false null-form)
  220.      (find-early-bindings bindings true '())))))
  221.  
  222. (define (process-evaluations evaluations test bindings receiver)
  223.   (if (null? evaluations)
  224.       (receiver test bindings)
  225.       (let ((evaluation (car evaluations)))
  226.     (build-comparison (cdr evaluation)
  227.               (cdar evaluation)
  228.               (lambda (new-test new-bindings)
  229.                 (process-evaluations
  230.                  (cdr evaluations)
  231.                  (scode/merge-tests new-test test)
  232.                  (append new-bindings bindings)
  233.                  receiver))))))
  234.  
  235. ;;;; Early variable processing
  236.  
  237. (define (bind-variable-early var+pattern variables receiver)
  238.   (let ((name (car var+pattern))
  239.     (expression (cdr var+pattern)))
  240.     (let ((var (assq name variables)))
  241.       (cond ((not var)
  242.          (error "match-bind: nonexistent variable"
  243.             name variables))
  244.         ((null? (cdr var))
  245.          (let ((exp (unevaluate expression)))
  246.            (receiver true
  247.              (list
  248.               (if (scode/constant? exp)
  249.                   (make-early-binding name exp)
  250.                   (make-outer-binding name exp))))))
  251.         (else
  252.          (if (not (eq? (caadr var) '?))
  253.          (error "match-bind: ?@ unimplemented" var))
  254.          (let ((transformer (cadr (cadr var)))
  255.            (rename (if (null? (cddr (cadr var)))
  256.                    name
  257.                    (caddr (cadr var)))))
  258.            (apply-transformer-early transformer name rename
  259.                     expression receiver)))))))
  260.  
  261. (define (unevaluate exp)
  262.   (cond ((not (pair? exp))
  263.      (scode/make-constant exp))
  264.     ((evaluation? exp)
  265.      (evaluation-expression exp))
  266.     (else
  267.      (let ((the-car (unevaluate (car exp)))
  268.            (the-cdr (unevaluate (cdr exp))))
  269.       (if (and (scode/constant? the-car)
  270.            (scode/constant? the-cdr))
  271.           (scode/make-constant (cons (scode/constant-value the-car)
  272.                      (scode/constant-value the-cdr)))
  273.           (scode/make-absolute-combination 'CONS
  274.                            (list the-car the-cdr)))))))
  275.  
  276. ;;;; Rule output code
  277.  
  278. (define (generate-match-code testo testi bindings body null-form receiver)
  279.   (define (scode/make-test test body)
  280.     (if (eq? test true)
  281.     body
  282.     (scode/make-conditional test body null-form)))
  283.  
  284.   (define (collect-bindings bindings outer late early outer-names early-names)
  285.     (if (null? bindings)
  286.     (receiver
  287.      (if (and (eq? testo true) (eq? testi true))
  288.          true
  289.          'MAYBE)
  290.      (scode/make-test
  291.       testo
  292.       (scode/make-block
  293.        outer outer-names
  294.        (scode/make-block late '()
  295.                  (scode/make-test
  296.                   testi
  297.                   (scode/make-block early early-names
  298.                         body))))))
  299.     (let ((binding (cdar bindings)))
  300.       (case (caar bindings)
  301.         ((OUTER)
  302.          (collect-bindings
  303.           (cdr bindings) (cons binding outer)
  304.           late early
  305.           (if (or (scode/constant? (scode/binding-value binding))
  306.               (scode/variable? (scode/binding-value binding)))
  307.           (cons (scode/binding-variable binding)
  308.             outer-names)
  309.           outer-names)
  310.           early-names))
  311.         ((LATE)
  312.          (collect-bindings (cdr bindings) outer
  313.                    (cons binding late) early
  314.                    outer-names early-names))
  315.         ((EARLY)
  316.          (collect-bindings (cdr bindings) outer
  317.                    late (cons binding early)
  318.                    outer-names
  319.                    (cons (scode/binding-variable binding)
  320.                      early-names)))
  321.         (else (error "collect bindings: Unknown type of binding"
  322.              (caar bindings)))))))
  323.   (collect-bindings bindings '() '() '() '() '()))
  324.  
  325. (define ((make-binding-procedure keyword) name exp)
  326.   (cons keyword (scode/make-binding name exp)))
  327.  
  328. (define make-early-binding (make-binding-procedure 'EARLY))
  329. (define make-late-binding (make-binding-procedure 'LATE))
  330. (define make-outer-binding (make-binding-procedure 'OUTER))
  331.  
  332. ;;;; Compiled pattern match
  333.  
  334. (define (build-comparison pattern expression receiver)
  335.   (define (merge-path path expression)
  336.     (if (null? path)
  337.     expression
  338.     (scode/make-absolute-combination path (list expression))))
  339.  
  340.   (define (walk pattern path expression receiver)
  341.     (cond ((not (pair? pattern))
  342.        (receiver true
  343.              (scode/make-absolute-combination 'EQ?
  344.               (list
  345.                (scode/make-constant pattern)
  346.                (merge-path path expression)))
  347.              '()))
  348.       ((pattern-variable? pattern)
  349.        (receiver false true
  350.              (list `(,(pattern-variable-name pattern)
  351.                  ,@(make-evaluation
  352.                 (merge-path path expression))))))
  353.       (else
  354.        (path-step 'CAR path expression
  355.         (lambda (car-path car-expression)
  356.           (walk (car pattern) car-path car-expression
  357.            (lambda (car-pure? car-test car-bindings)
  358.          (path-step 'CDR path expression
  359.           (lambda (cdr-path cdr-expression)
  360.             (walk (cdr pattern) cdr-path cdr-expression
  361.              (lambda (cdr-pure? cdr-test cdr-bindings)
  362.                (let ((result (and car-pure? cdr-pure?)))
  363.              (receiver
  364.               result
  365.               (build-pair-test result car-test cdr-test
  366.                        (merge-path path expression))
  367.               (append car-bindings cdr-bindings))))))))))))))
  368.  
  369.   (walk pattern '() expression
  370.     (lambda (pure? test bindings)
  371.       pure?
  372.       (receiver test bindings))))
  373.  
  374. ;;; car/cdr decomposition
  375.  
  376. (define (build-pair-test pure? car-test cdr-test expression)
  377.   (if (not pure?)
  378.       (scode/merge-tests (scode/make-absolute-combination 'PAIR?
  379.                               (list expression))
  380.              (scode/merge-tests car-test cdr-test))
  381.       (combination-components car-test
  382.     (lambda (car-operator car-operands)
  383.       car-operator
  384.       (combination-components cdr-test
  385.         (lambda (cdr-operator cdr-operands)
  386.           cdr-operator
  387.           (scode/make-absolute-combination 'EQUAL?
  388.            (list
  389.         (scode/make-constant
  390.          (cons (scode/constant-value (car car-operands))
  391.                (scode/constant-value (car cdr-operands))))
  392.            expression))))))))
  393.  
  394. ;;;; car/cdr path compression
  395.  
  396. ;; The rest of the elements are provided for canonicalization, not used.
  397.  
  398. (define path-compressions
  399.   '((car (caar . cdar) car)
  400.     (cdr (cadr . cddr) cdr)
  401.  
  402.     (caar (caaar . cdaar) car car)
  403.     (cadr (caadr . cdadr) car cdr)
  404.     (cdar (cadar . cddar) cdr car)
  405.     (cddr (caddr . cdddr) cdr cdr)
  406.  
  407.     (caaar (caaaar . cdaaar) car caar)
  408.     (caadr (caaadr . cdaadr) car cadr)
  409.     (cadar (caadar . cdadar) car cdar)
  410.     (caddr (caaddr . cdaddr) car cddr)
  411.     (cdaar (cadaar . cddaar) cdr caar)
  412.     (cdadr (cadadr . cddadr) cdr cadr)
  413.     (cddar (caddar . cdddar) cdr cdar)
  414.     (cdddr (cadddr . cddddr) cdr cddr)
  415.  
  416.     (caaaar () car caaar)
  417.     (caaadr () car caadr)
  418.     (caadar () car cadar)
  419.     (caaddr () car caddr)
  420.     (cadaar () car cdaar)
  421.     (cadadr () car cdadr)
  422.     (caddar () car cddar)
  423.     (cadddr () car cdddr)
  424.     (cdaaar () cdr caaar)
  425.     (cdaadr () cdr caadr)
  426.     (cdadar () cdr cadar)
  427.     (cdaddr () cdr caddr)
  428.     (cddaar () cdr cdaar)
  429.     (cddadr () cdr cdadr)
  430.     (cdddar () cdr cddar)
  431.     (cddddr () cdr cdddr)))
  432.  
  433. (define (path-step step path expression receiver)
  434.   (let ((info (assq path path-compressions)))
  435.     (cond ((not info)
  436.        (receiver step expression))
  437.       ((null? (cadr info))
  438.        (receiver step
  439.              (scode/make-absolute-combination path (list expression))))
  440.       (else
  441.        (receiver (if (eq? step 'CAR) (caadr info) (cdadr info))
  442.              expression)))))
  443.  
  444. ;;;; Transformers
  445.  
  446. (define (apply-transformer-early trans-exp name rename exp receiver)
  447.   (let ((transformer (find-transformer trans-exp)))
  448.     (if transformer
  449.     (transformer trans-exp name rename exp receiver)
  450.     (apply-transformer trans-exp name rename exp receiver))))
  451.  
  452. (define (apply-transformer transformer name rename exp receiver)
  453.   (receiver (scode/make-variable name)
  454.         (transformer-bindings name rename (unevaluate exp)
  455.          (lambda (exp)
  456.            (scode/make-combination (scode/make-variable transformer)
  457.                        (list exp))))))
  458.       
  459. (define (transformer-bindings name rename expression mapper)
  460.   (if (eq? rename name)
  461.       (list (make-outer-binding name (mapper expression)))
  462.       (list (make-outer-binding rename expression)
  463.         (make-late-binding name (mapper (scode/make-variable rename))))))
  464.  
  465. (define *transformers*)
  466.  
  467. (define (find-transformer expression)
  468.   (and (symbol? expression)
  469.        (let ((place (assq expression *transformers*)))
  470.      (and place
  471.           (cdr place)))))
  472.  
  473. ;;;; Database transformers
  474.  
  475. (define (make-database-transformer database)
  476.   (lambda (texp name rename exp receiver)
  477.     (let ((null-form
  478.        (scode/make-constant (generate-uninterned-symbol 'NOT-FOUND-))))
  479.       (try-rules database exp null-form
  480.        (lambda (result code)
  481.      (define (possible test make-binding)
  482.        (receiver test
  483.              (cons (make-binding rename code)
  484.                (if (eq? name rename)
  485.                    '()
  486.                    (list (make-binding name
  487.                            (unevaluate exp)))))))
  488.  
  489.      (cond ((false? result)
  490.         (transformer-fail receiver))
  491.            ((eq? result 'TOO-MANY)
  492.         (apply-transformer texp name rename exp receiver))
  493.            ((eq? result 'MAYBE)
  494.         (possible (make-simple-transformer-test name null-form)
  495.               make-outer-binding))
  496.            ((can-integrate? code)
  497.         (possible true make-early-binding))
  498.            (else        
  499.         (possible true make-late-binding))))))))
  500.  
  501. ;; Mega kludge!
  502.  
  503. (define (can-integrate? code)
  504.   (if (not (scode/let? code))
  505.       true
  506.       (scode/let-components
  507.        code
  508.        (lambda (names values decls body)
  509.      values
  510.      (and (not (null? names))
  511.           (let ((place (assq 'INTEGRATE decls)))
  512.         (and (not (null? place))
  513.              (let ((integrated (cdr place)))
  514.                (let loop ((left names))
  515.              (cond ((null? left)
  516.                 (can-integrate? body))
  517.                    ((memq (car left) integrated)
  518.                 (loop (cdr left)))
  519.                    (else false)))))))))))
  520.  
  521. (define-integrable (make-simple-transformer-test name tag)
  522.   (scode/make-absolute-combination 'NOT
  523.    (list (scode/make-absolute-combination 'EQ?
  524.       (list
  525.        (scode/make-variable name)
  526.        tag)))))
  527.  
  528. (define-integrable (transformer-fail receiver)
  529.   (receiver false false))
  530.  
  531. (define-integrable (transformer-result receiver name rename out in)
  532.   (receiver true
  533.         (cons (make-early-binding name (scode/make-constant out))
  534.           (if (eq? name rename)
  535.               '()
  536.               (list (make-early-binding rename
  537.                         (scode/make-constant in)))))))
  538.  
  539. ;;;; Symbol transformers
  540.  
  541. (define (make-symbol-transformer alist)
  542.   (lambda (texp name rename exp receiver)
  543.     texp
  544.     (cond ((null? alist)
  545.        (receiver false false))
  546.       ((symbol? exp)
  547.        (let ((pair (assq exp alist)))
  548.          (if (not pair)
  549.          (transformer-fail receiver)
  550.          (transformer-result receiver name rename (cdr pair) exp))))
  551.       ((evaluation? exp)
  552.        (let ((tag (generate-uninterned-symbol 'NOT-FOUND-)))
  553.          (receiver
  554.           (make-simple-transformer-test name (scode/make-constant tag))
  555.           (transformer-bindings name
  556.                     rename
  557.                     (evaluation-expression exp)
  558.                     (lambda (expr)
  559.                       (runtime-symbol-lookup tag
  560.                                  expr
  561.                                  alist))))))
  562.       (else (transformer-fail receiver)))))
  563.  
  564. (define (runtime-symbol-lookup not-found-tag expression alist)
  565.   (if (>= (length alist) 4)
  566.       (scode/make-absolute-combination 'CDR
  567.        (list
  568.     (scode/make-disjunction
  569.      (scode/make-absolute-combination 'ASSQ
  570.       (list expression
  571.         (scode/make-constant alist)))
  572.      (scode/make-constant `(() . ,not-found-tag)))))
  573.       (scode/make-case-expression
  574.        expression
  575.        (scode/make-constant not-found-tag)
  576.        (map (lambda (pair)
  577.           (list (list (car pair))
  578.             (scode/make-constant (cdr pair))))
  579.         alist))))
  580.  
  581. ;;;; Accumulation transformers
  582.  
  583. (define (make-bit-mask-transformer size alist)
  584.   (lambda (texp name rename exp receiver)
  585.     (cond ((null? alist)
  586.        (transformer-fail receiver))
  587.       ((evaluation? exp)
  588.        (apply-transformer texp name rename exp receiver))
  589.       (else
  590.        (let ((mask (make-bit-string size #!FALSE)))
  591.          (define (loop symbols)
  592.            (cond ((null? symbols)
  593.               (transformer-result receiver name rename mask exp))
  594.              ((not (pair? symbols))
  595.               (transformer-fail receiver))
  596.              ((not (symbol? (car symbols)))
  597.               (apply-transformer texp name rename exp receiver))
  598.              (else
  599.               (let ((place (assq (car symbols) alist)))
  600.             (if (not place)
  601.                 (transformer-fail receiver)
  602.                 (begin (bit-string-set! mask (cdr place))
  603.                    (loop (cdr symbols))))))))
  604.          (loop exp))))))
  605.  
  606. ;;;; Scode utilities
  607.  
  608. (define-integrable scode/make-binding cons)
  609. (define-integrable scode/binding-variable car)
  610. (define-integrable scode/binding-value cdr)
  611.  
  612. (define-integrable (scode/make-conjunction t1 t2)
  613.   (scode/make-conditional t1 t2 (scode/make-constant false)))
  614.  
  615. (define (scode/merge-tests t1 t2)
  616.   (cond ((eq? t1 true) t2)
  617.     ((eq? t2 true) t1)
  618.     (else (scode/make-conjunction t1 t2))))
  619.  
  620. (define (scode/make-thunk body)
  621.   (scode/make-lambda lambda-tag:unnamed '() '() false '() '() body))  
  622.  
  623. (define (scode/let? obj)
  624.   (and (scode/combination? obj)
  625.        (scode/combination-components
  626.     obj
  627.     (lambda (operator operands)
  628.       operands
  629.       (and (scode/lambda? operator)
  630.            (scode/lambda-components
  631.         operator
  632.         (lambda (name . ignore)
  633.           ignore
  634.           (eq? name lambda-tag:let))))))))
  635.  
  636. (define (scode/make-let names values declarations body)
  637.   (scode/make-combination
  638.    (scode/make-lambda lambda-tag:let
  639.               names
  640.               '()
  641.               false
  642.               '()
  643.               declarations
  644.               body)
  645.    values))
  646.  
  647. (define (scode/let-components lcomb receiver)
  648.   (scode/combination-components lcomb
  649.    (lambda (operator values)
  650.      (scode/lambda-components operator
  651.       (lambda (tag names opt rest aux decls body)
  652.     tag opt rest aux
  653.     (receiver names values decls body))))))                     
  654.  
  655. ;;;; Scode utilities (continued)
  656.  
  657. (define (scode/make-block bindings integrated body)
  658.   (if (null? bindings)
  659.       body
  660.       (scode/make-let (map scode/binding-variable bindings)
  661.               (map scode/binding-value bindings)
  662.               (if (null? integrated)
  663.               '()
  664.               `((INTEGRATE ,@integrated)))
  665.               body)))
  666.  
  667. (define (scode/make-letrec bindings body)
  668.   (scode/make-let
  669.    (map scode/binding-variable bindings)
  670.    (make-list (length bindings)
  671.           (make-unassigned-reference-trap))
  672.    '()
  673.    (scode/make-sequence
  674.     (map* body
  675.       (lambda (binding)
  676.         (scode/make-assignment (scode/binding-variable binding)
  677.                    (scode/binding-value binding)))
  678.       bindings))))
  679.  
  680. (define (scode/make-case-expression expression default clauses)
  681.   (define (kernel case-selector)
  682.     (define (process clauses)
  683.       (if (null? clauses)
  684.       default
  685.       (let ((selector (caar clauses)))
  686.         (scode/make-conditional
  687.          (if (null? (cdr selector))
  688.          (scode/make-absolute-combination 'EQ?
  689.           (list case-selector
  690.             (scode/make-constant (car selector))))
  691.          (scode/make-absolute-combination 'MEMQ
  692.           (list case-selector
  693.             (scode/make-constant selector))))
  694.          (cadar clauses)
  695.          (process (cdr clauses))))))
  696.     (process clauses))
  697.  
  698.   (if (scode/variable? expression)
  699.       (kernel expression)
  700.       (let ((var (make-variable-name 'CASE-SELECTOR-)))
  701.     (scode/make-let (list var) (list expression) '()
  702.             (kernel (scode/make-variable var))))))
  703.  
  704. (define make-variable-name generate-uninterned-symbol)
  705.  
  706. (define evaluation-tag (list '*EVALUATION*))
  707.  
  708. (define (evaluation? exp)
  709.   (and (pair? exp)
  710.        (eq? (car exp) evaluation-tag)))
  711.  
  712. (define-integrable (make-evaluation name)
  713.   (cons evaluation-tag name))
  714.  
  715. (define-integrable (evaluation-expression exp)
  716.   (cdr exp))