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 / macros.scm < prev    next >
Text File  |  1999-01-02  |  11KB  |  331 lines
  1. #| -*-Scheme-*-
  2.  
  3. $Id: macros.scm,v 4.16 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. ;;;; Compiler Macros
  23. ;;; package: (compiler macros)
  24.  
  25. (declare (usual-integrations))
  26.  
  27. (define (initialize-package!)
  28.   (for-each (lambda (entry)
  29.           (syntax-table-define compiler-syntax-table (car entry)
  30.         (cadr entry)))
  31.         `((CFG-NODE-CASE ,transform/cfg-node-case)
  32.           (DEFINE-ENUMERATION ,transform/define-enumeration)
  33.           (DEFINE-EXPORT ,transform/define-export)
  34.           (DEFINE-LVALUE ,transform/define-lvalue)
  35.           (DEFINE-PNODE ,transform/define-pnode)
  36.           (DEFINE-ROOT-TYPE ,transform/define-root-type)
  37.           (DEFINE-RTL-EXPRESSION ,transform/define-rtl-expression)
  38.           (DEFINE-RTL-PREDICATE ,transform/define-rtl-predicate)
  39.           (DEFINE-RTL-STATEMENT ,transform/define-rtl-statement)
  40.           (DEFINE-RULE ,transform/define-rule)
  41.           (DEFINE-RVALUE ,transform/define-rvalue)
  42.           (DEFINE-SNODE ,transform/define-snode)
  43.           (DEFINE-VECTOR-SLOTS ,transform/define-vector-slots)
  44.           (DESCRIPTOR-LIST ,transform/descriptor-list)
  45.           (ENUMERATION-CASE ,transform/enumeration-case)
  46.           (INST-EA ,transform/inst-ea)
  47.           (LAP ,transform/lap)
  48.           (LAST-REFERENCE ,transform/last-reference)
  49.           (MAKE-LVALUE ,transform/make-lvalue)
  50.           (MAKE-PNODE ,transform/make-pnode)
  51.           (MAKE-RVALUE ,transform/make-rvalue)
  52.           (MAKE-SNODE ,transform/make-snode)
  53.           (PACKAGE ,transform/package)))
  54.   (syntax-table-define lap-generator-syntax-table 'DEFINE-RULE
  55.     transform/define-rule))
  56.  
  57. (define compiler-syntax-table
  58.   (make-syntax-table syntax-table/system-internal))
  59.  
  60. (define lap-generator-syntax-table
  61.   (make-syntax-table compiler-syntax-table))
  62.  
  63. (define assembler-syntax-table
  64.   (make-syntax-table compiler-syntax-table))
  65.  
  66. (define early-syntax-table
  67.   (make-syntax-table compiler-syntax-table))
  68.  
  69. (define transform/last-reference
  70.   (macro (name)
  71.     (let ((x (generate-uninterned-symbol)))
  72.       `(IF COMPILER:PRESERVE-DATA-STRUCTURES?
  73.        ,name
  74.        (LET ((,x ,name))
  75.          (SET! ,name)
  76.          ,x)))))
  77.  
  78. (define (transform/package names . body)
  79.   (make-syntax-closure
  80.    (make-sequence
  81.     `(,@(map (lambda (name)
  82.            (make-definition name (make-unassigned-reference-trap)))
  83.          names)
  84.       ,(make-combination
  85.     (let ((block (syntax* (append body (list unspecific)))))
  86.       (if (open-block? block)
  87.           (open-block-components block
  88.         (lambda (names* declarations body)
  89.           (make-lambda lambda-tag:let '() '() false
  90.                    (list-transform-negative names*
  91.                  (lambda (name)
  92.                    (memq name names)))
  93.                    declarations
  94.                    body)))
  95.           (make-lambda lambda-tag:let '() '() false '()
  96.                '() block)))
  97.     '())))))
  98.  
  99. (define transform/define-export
  100.   (macro (pattern . body)
  101.     (parse-define-syntax pattern body
  102.       (lambda (name body)
  103.     name
  104.     `(SET! ,pattern ,@body))
  105.       (lambda (pattern body)
  106.     `(SET! ,(car pattern)
  107.            (NAMED-LAMBDA ,pattern ,@body))))))
  108.  
  109. (define transform/define-vector-slots
  110.   (macro (class index . slots)
  111.     (define (loop slots n)
  112.       (if (null? slots)
  113.       '()
  114.       (let ((make-defs
  115.          (lambda (slot)
  116.            (let ((ref-name (symbol-append class '- slot)))
  117.              `(BEGIN
  118.             (DEFINE-INTEGRABLE (,ref-name ,class)
  119.               (VECTOR-REF ,class ,n))
  120.             (DEFINE-INTEGRABLE (,(symbol-append 'SET- ref-name '!)
  121.                         ,class ,slot)
  122.               (VECTOR-SET! ,class ,n ,slot))))))
  123.         (rest (loop (cdr slots) (1+ n))))
  124.         (if (pair? (car slots))
  125.         (map* rest make-defs (car slots))
  126.         (cons (make-defs (car slots)) rest)))))
  127.     (if (null? slots)
  128.     '*THE-NON-PRINTING-OBJECT*
  129.     `(BEGIN ,@(loop slots index)))))
  130.  
  131. (define transform/define-root-type
  132.   (macro (type . slots)
  133.     (let ((tag-name (symbol-append type '-TAG)))
  134.       `(BEGIN (DEFINE ,tag-name
  135.         (MAKE-VECTOR-TAG FALSE ',type FALSE))
  136.           (DEFINE ,(symbol-append type '?)
  137.         (TAGGED-VECTOR/SUBCLASS-PREDICATE ,tag-name))
  138.           (DEFINE-VECTOR-SLOTS ,type 1 ,@slots)
  139.           (SET-VECTOR-TAG-DESCRIPTION!
  140.            ,tag-name
  141.            (LAMBDA (,type)
  142.          (DESCRIPTOR-LIST ,type ,@slots)))))))
  143.  
  144. (define transform/descriptor-list
  145.   (macro (type . slots)
  146.     (let ((ref-name (lambda (slot) (symbol-append type '- slot))))
  147.       `(LIST ,@(map (lambda (slot)
  148.               (if (pair? slot)
  149.               (let ((ref-names (map ref-name slot)))
  150.                 ``(,',ref-names ,(,(car ref-names) ,type)))
  151.               (let ((ref-name (ref-name slot)))
  152.                 ``(,',ref-name ,(,ref-name ,type)))))
  153.             slots)))))
  154.  
  155. (let-syntax
  156.  ((define-type-definition
  157.     (macro (name reserved enumeration)
  158.       (let ((parent (symbol-append name '-TAG)))
  159.     `(DEFINE ,(symbol-append 'TRANSFORM/DEFINE- name)
  160.        (macro (type . slots)
  161.          (let ((tag-name (symbol-append type '-TAG)))
  162.            `(BEGIN (DEFINE ,tag-name
  163.              (MAKE-VECTOR-TAG ,',parent ',type ,',enumeration))
  164.                (DEFINE ,(symbol-append type '?)
  165.              (TAGGED-VECTOR/PREDICATE ,tag-name))
  166.                (DEFINE-VECTOR-SLOTS ,type ,,reserved ,@slots)
  167.                (SET-VECTOR-TAG-DESCRIPTION!
  168.             ,tag-name
  169.             (LAMBDA (,type)
  170.               (APPEND!
  171.                ((VECTOR-TAG-DESCRIPTION ,',parent) ,type)
  172.                (DESCRIPTOR-LIST ,type ,@slots))))))))))))
  173.  (define-type-definition snode 5 false)
  174.  (define-type-definition pnode 6 false)
  175.  (define-type-definition rvalue 2 rvalue-types)
  176.  (define-type-definition lvalue 14 false))
  177.  
  178. ;;; Kludge to make these compile efficiently.
  179.  
  180. (define transform/make-snode
  181.   (macro (tag . extra)
  182.     `((ACCESS VECTOR ,system-global-environment)
  183.       ,tag FALSE '() '() FALSE ,@extra)))
  184.  
  185. (define transform/make-pnode
  186.   (macro (tag . extra)
  187.     `((ACCESS VECTOR ,system-global-environment)
  188.       ,tag FALSE '() '() FALSE FALSE ,@extra)))
  189.  
  190. (define transform/make-rvalue
  191.   (macro (tag . extra)
  192.     `((ACCESS VECTOR ,system-global-environment)
  193.       ,tag FALSE ,@extra)))
  194.  
  195. (define transform/make-lvalue
  196.   (macro (tag . extra)
  197.     (let ((result (generate-uninterned-symbol)))
  198.       `(let ((,result
  199.           ((ACCESS VECTOR ,system-global-environment)
  200.            ,tag FALSE '() '() '() '() '() '() 'NOT-CACHED
  201.            FALSE '() FALSE FALSE '() ,@extra)))
  202.      (SET! *LVALUES* (CONS ,result *LVALUES*))
  203.      ,result))))
  204.  
  205. (define transform/define-rtl-expression)
  206. (define transform/define-rtl-statement)
  207. (define transform/define-rtl-predicate)
  208. (let ((rtl-common
  209.        (lambda (type prefix components wrap-constructor types)
  210.      `(BEGIN
  211.         (SET! ,types (CONS ',type ,types))
  212.         (DEFINE-INTEGRABLE
  213.           (,(symbol-append prefix 'MAKE- type) ,@components)
  214.           ,(wrap-constructor `(LIST ',type ,@components)))
  215.         (DEFINE-INTEGRABLE (,(symbol-append 'RTL: type '?) EXPRESSION)
  216.           (EQ? (CAR EXPRESSION) ',type))
  217.         ,@(let loop ((components components)
  218.              (ref-index 6)
  219.              (set-index 2))
  220.         (if (null? components)
  221.             '()
  222.             (let* ((slot (car components))
  223.                (name (symbol-append type '- slot)))
  224.               `((DEFINE-INTEGRABLE (,(symbol-append 'RTL: name) ,type)
  225.               (GENERAL-CAR-CDR ,type ,ref-index))
  226.             ,(let ((slot (if (eq? slot type)
  227.                      (symbol-append slot '-VALUE)
  228.                      slot)))
  229.                `(DEFINE-INTEGRABLE
  230.                   (,(symbol-append 'RTL:SET- name '!)
  231.                    ,type ,slot)
  232.                   (SET-CAR! (GENERAL-CAR-CDR ,type ,set-index)
  233.                     ,slot)))
  234.             ,@(loop (cdr components)
  235.                 (* ref-index 2)
  236.                 (* set-index 2))))))))))
  237.   (set! transform/define-rtl-expression
  238.     (macro (type prefix . components)
  239.       (rtl-common type prefix components
  240.               identity-procedure
  241.               'RTL:EXPRESSION-TYPES)))
  242.  
  243.   (set! transform/define-rtl-statement
  244.     (macro (type prefix . components)
  245.       (rtl-common type prefix components
  246.               (lambda (expression) `(STATEMENT->SRTL ,expression))
  247.               'RTL:STATEMENT-TYPES)))
  248.  
  249.   (set! transform/define-rtl-predicate
  250.     (macro (type prefix . components)
  251.       (rtl-common type prefix components
  252.               (lambda (expression) `(PREDICATE->PRTL ,expression))
  253.               'RTL:PREDICATE-TYPES))))
  254.  
  255. (define transform/define-rule
  256.   (macro (type pattern . body)
  257.     (parse-rule pattern body
  258.       (lambda (pattern variables qualifier actions)
  259.     `(,(case type
  260.          ((STATEMENT) 'ADD-STATEMENT-RULE!)
  261.          ((PREDICATE) 'ADD-STATEMENT-RULE!)
  262.          ((REWRITING) 'ADD-REWRITING-RULE!)
  263.          (else type))
  264.       ',pattern
  265.       ,(rule-result-expression variables qualifier
  266.                    `(BEGIN ,@actions)))))))
  267.  
  268. ;;;; Lap instruction sequences.
  269.  
  270. (define transform/lap
  271.   (macro some-instructions
  272.     (list 'QUASIQUOTE some-instructions)))
  273.  
  274. (define transform/inst-ea
  275.   (macro (ea)
  276.     (list 'QUASIQUOTE ea)))
  277.  
  278. (define transform/define-enumeration
  279.   (macro (name elements)
  280.     (let ((enumeration (symbol-append name 'S)))
  281.       `(BEGIN (DEFINE ,enumeration
  282.         (MAKE-ENUMERATION ',elements))
  283.           ,@(map (lambda (element)
  284.                `(DEFINE ,(symbol-append name '/ element)
  285.               (ENUMERATION/NAME->INDEX ,enumeration ',element)))
  286.              elements)))))
  287.  
  288. (define (macros/case-macro expression clauses predicate default)
  289.   (let ((need-temp? (not (symbol? expression))))
  290.     (let ((expression*
  291.        (if need-temp?
  292.            (generate-uninterned-symbol)
  293.            expression)))
  294.       (let ((body
  295.          `(COND
  296.            ,@(let loop ((clauses clauses))
  297.            (cond ((null? clauses)
  298.               (default expression*))
  299.              ((eq? (caar clauses) 'ELSE)
  300.               (if (null? (cdr clauses))
  301.                   clauses
  302.                   (error "ELSE clause not last" clauses)))
  303.              (else
  304.               `(((OR ,@(map (lambda (element)
  305.                       (predicate expression* element))
  306.                     (caar clauses)))
  307.                  ,@(cdar clauses))
  308.                 ,@(loop (cdr clauses)))))))))
  309.     (if need-temp?
  310.         `(LET ((,expression* ,expression))
  311.            ,body)
  312.         body)))))
  313.  
  314. (define transform/enumeration-case
  315.   (macro (name expression . clauses)
  316.     (macros/case-macro expression
  317.                clauses
  318.                (lambda (expression element)
  319.              `(EQ? ,expression ,(symbol-append name '/ element)))
  320.                (lambda (expression)
  321.              expression
  322.              '()))))
  323.  
  324. (define transform/cfg-node-case
  325.   (macro (expression . clauses)
  326.     (macros/case-macro expression
  327.                clauses
  328.                (lambda (expression element)
  329.              `(EQ? ,expression ,(symbol-append element '-TAG)))
  330.                (lambda (expression)
  331.              `((ELSE (ERROR "Unknown node type" ,expression)))))))