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 / back / syerly.scm < prev    next >
Encoding:
Text File  |  1999-01-02  |  7.4 KB  |  229 lines
  1. #| -*-Scheme-*-
  2.  
  3. $Id: syerly.scm,v 1.11 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. ;;;; Syntax time instruction expansion
  23. ;;; package: (compiler lap-syntaxer)
  24.  
  25. (declare (usual-integrations))
  26.  
  27. ;;;; Early instruction assembly
  28.  
  29. (define lap:syntax-instruction-expander
  30.   (scode->scode-expander
  31.    (lambda (operands if-expanded if-not-expanded)
  32.      (let ((instruction (scode/unquasiquote (car operands))))
  33.        (let ((ierror
  34.           (lambda (message)
  35.         (error (string-append "LAP:SYNTAX-INSTRUCTION-EXPANDER: "
  36.                       message)
  37.                instruction))))
  38.      (if (not (pair? instruction))
  39.          (ierror "bad instruction"))
  40.      (cond ((eq? (car instruction) 'UNQUOTE)
  41.         (if-not-expanded))
  42.            ((memq (car instruction)
  43.               '(EQUATE SCHEME-OBJECT SCHEME-EVALUATION
  44.                    ENTRY-POINT LABEL BLOCK-OFFSET))
  45.         (if-expanded
  46.          (scode/make-combination
  47.           (scode/make-variable  'DIRECTIVE->INSTRUCTION-SEQUENCE)
  48.           operands)))
  49.            (else
  50.         (let ((place (assq (car instruction) early-instructions)))
  51.           (if (not place)
  52.               (ierror "unknown opcode"))
  53.           (let ((opcode (car instruction))
  54.             (body (cdr instruction))
  55.             (rules (cdr place)))
  56.             (early-pattern-lookup
  57.              rules
  58.              body
  59.              early-transformers
  60.              (scode/make-constant opcode)
  61.              (lambda (mode result)
  62.                (if (false? mode)
  63.                (ierror "unknown instruction"))
  64.                (if (eq? mode 'TOO-MANY)
  65.                (if-not-expanded)
  66.                (if-expanded result)))
  67.              1))))))))))
  68.  
  69. ;;;; Quasiquote unsyntaxing
  70.  
  71. (define (scode/unquasiquote exp)
  72.   (cond ((scode/combination? exp)
  73.      (scode/combination-components
  74.       exp
  75.       (lambda (operator operands)
  76.         (define (kernel operator-name)
  77.           (case operator-name
  78.         ((CONS)
  79.          (cons (scode/unquasiquote (car operands))
  80.                (scode/unquasiquote (cadr operands))))
  81.         ((LIST)
  82.          (apply list (map scode/unquasiquote operands)))
  83.         ((CONS*)
  84.          (apply cons* (map scode/unquasiquote operands)))
  85.         ((APPEND)
  86.          (append-map (lambda (component)
  87.                    (if (scode/constant? component)
  88.                    (scode/constant-value component)
  89.                    (list (list 'UNQUOTE-SPLICING component))))
  90.                  operands))
  91.         (else (list 'UNQUOTE exp))))
  92.         (cond ((eq? operator cons)
  93.            ;; integrations
  94.            (kernel 'CONS))
  95.           ((scode/absolute-reference? operator)
  96.            (kernel (scode/absolute-reference-name operator)))
  97.           (else (list 'UNQUOTE exp))))))
  98.     ((scode/constant? exp)
  99.      (scode/constant-value exp))
  100.     (else (list 'UNQUOTE exp))))
  101.  
  102. ;;;; Bit compression expanders
  103.  
  104. ;;; SYNTAX-EVALUATION and OPTIMIZE-GROUP expanders
  105.  
  106. (define syntax-evaluation-expander
  107.   (scode->scode-expander
  108.    (let ((environment
  109.       (package/environment (find-package '(COMPILER LAP-SYNTAXER)))))
  110.      (lambda (operands if-expanded if-not-expanded)
  111.        (if (and (scode/constant? (car operands))
  112.         (scode/variable? (cadr operands))
  113.         (not (lexical-unreferenceable?
  114.               environment
  115.               (scode/variable-name (cadr operands)))))
  116.        (if-expanded
  117.         (scode/make-constant
  118.          ((lexical-reference environment
  119.                  (scode/variable-name (cadr operands)))
  120.           (scode/constant-value (car operands)))))
  121.        (if-not-expanded))))))
  122.  
  123. ;; This relies on the fact that scode/constant-value = identity-procedure.
  124.  
  125. (define optimize-group-expander
  126.   (scode->scode-expander
  127.    (lambda (operands if-expanded if-not-expanded)
  128.      if-not-expanded
  129.      (optimize-group-internal
  130.       operands
  131.       (lambda (result make-group?)
  132.     (if make-group?
  133.         (if-expanded
  134.          (scode/make-combination (scode/make-variable 'OPTIMIZE-GROUP)
  135.                      result))
  136.         (if-expanded
  137.          (scode/make-constant result))))))))
  138.  
  139. ;;;; CONS-SYNTAX expander
  140.  
  141. (define (is-operator? expr name primitive)
  142.   (or (and primitive
  143.        (scode/constant? expr)
  144.        (eq? (scode/constant-value expr) primitive))
  145.       (and (scode/variable? expr)
  146.        (eq? (scode/variable-name expr) name))
  147.       (and (scode/absolute-reference? expr)
  148.        (eq? (scode/absolute-reference-name expr) name))))
  149.  
  150. (define cons-syntax-expander
  151.   (scode->scode-expander
  152.    (lambda (operands if-expanded if-not-expanded)
  153.      (let ((default
  154.          (lambda ()
  155.            (if (not (scode/constant? (cadr operands)))
  156.            (if-not-expanded)
  157.            (begin
  158.              (if (not (null? (scode/constant-value (cadr operands))))
  159.              (error "CONS-SYNTAX-EXPANDER: bad tail"
  160.                 (cadr operands)))
  161.              (if-expanded (scode/make-combination cons operands)))))))
  162.        (if (and (scode/constant? (car operands))
  163.         (bit-string? (scode/constant-value (car operands)))
  164.         (scode/combination? (cadr operands)))
  165.        (scode/combination-components (cadr operands)
  166.          (lambda (operator inner-operands)
  167.            (if (and (or (is-operator? operator 'CONS-SYNTAX false)
  168.                 (is-operator? operator 'CONS cons))
  169.             (scode/constant? (car inner-operands))
  170.             (bit-string?
  171.              (scode/constant-value (car inner-operands))))
  172.            (if-expanded
  173.             (scode/make-combination
  174.              (if (scode/constant? (cadr inner-operands))
  175.              cons
  176.              operator)
  177.              (cons (instruction-append
  178.                 (scode/constant-value (car operands))
  179.                 (scode/constant-value (car inner-operands)))
  180.                (cdr inner-operands))))
  181.            (default))))
  182.        (default))))))
  183.  
  184. ;;;; INSTRUCTION->INSTRUCTION-SEQUENCE expander
  185.  
  186. (define instruction->instruction-sequence-expander
  187.   (let ()
  188.     (define (parse expression receiver)
  189.       (if (not (scode/combination? expression))
  190.       (receiver false false false)
  191.       (scode/combination-components expression
  192.         (lambda (operator operands)
  193.           (cond ((and (not (is-operator? operator 'CONS cons))
  194.               (not (is-operator? operator 'CONS-SYNTAX false)))
  195.              (receiver false false false))
  196.             ((scode/constant? (cadr operands))
  197.              (if (not (null? (scode/constant-value (cadr operands))))
  198.              (error "INST->INST-SEQ-EXPANDER: bad CONS-SYNTAX tail"
  199.                 (scode/constant-value (cadr operands))))
  200.              (let ((name
  201.                 (generate-uninterned-symbol 'INSTRUCTION-TAIL-)))
  202.                (receiver true
  203.                  (cons name expression)
  204.                  (scode/make-variable name))))
  205.             (else
  206.              (parse (cadr operands)
  207.                (lambda (mode info rest)
  208.              (if (not mode)
  209.                  (receiver false false false)
  210.                  (receiver true info
  211.                        (scode/make-combination
  212.                     operator
  213.                     (list (car operands) rest))))))))))))
  214.     (scode->scode-expander
  215.      (lambda (operands if-expanded if-not-expanded)
  216.        (if (not (scode/combination? (car operands)))
  217.        (if-not-expanded)
  218.        (parse (car operands)
  219.          (lambda (mode binding rest)
  220.            (if (not mode)
  221.            (if-not-expanded)
  222.            (if-expanded
  223.             (scode/make-let
  224.              (list (car binding))
  225.              (list (cdr binding))
  226.              (scode/make-combination
  227.               cons
  228.               (list rest
  229.                 (scode/make-variable (car binding))))))))))))))