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 / macros.scm < prev    next >
Text File  |  1999-01-02  |  11KB  |  348 lines
  1. #| -*-Scheme-*-
  2.  
  3. $Id: macros.scm,v 1.3 1999/01/02 06:11:34 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. ;;;; More Special Forms
  23. ;;; package: (runtime macros)
  24.  
  25. (declare (usual-integrations))
  26.  
  27. (define (initialize-package!)
  28.   (for-each (lambda (keyword transform)
  29.           (syntax-table-define system-global-syntax-table keyword
  30.         transform))
  31.         '(AND
  32.           CASE
  33.           CONS-STREAM
  34.           DEFINE-INTEGRABLE
  35.           DO
  36.           LET*
  37.           LETREC
  38.           MAKE-ENVIRONMENT
  39.           QUASIQUOTE
  40.           SEQUENCE)
  41.         (list transform/and
  42.           transform/case
  43.           transform/cons-stream
  44.           transform/define-integrable
  45.           transform/do
  46.           transform/let*
  47.           transform/letrec
  48.           transform/make-environment
  49.           transform/quasiquote
  50.           transform/sequence)))
  51.  
  52. (define (make-absolute-reference name)
  53.   `(ACCESS ,name #F))
  54.  
  55. (define (transform/and . expressions)
  56.   (if (null? expressions)
  57.       '#T
  58.       (let loop ((expressions expressions))
  59.     (if (null? (cdr expressions))
  60.         (car expressions)
  61.         `(IF ,(car expressions)
  62.          ,(loop (cdr expressions))
  63.          #F)))))
  64.  
  65. (define (transform/cons-stream head tail)
  66.   `(,(make-absolute-reference 'CONS) ,head (DELAY ,tail)))
  67.  
  68. (define (transform/make-environment . body)
  69.   `((NAMED-LAMBDA (,lambda-tag:make-environment)
  70.       ,@body
  71.       (THE-ENVIRONMENT))))
  72.  
  73. (define (transform/sequence . actions)
  74.   `(BEGIN . ,actions))
  75.  
  76. ;;;; Quasiquote
  77.  
  78. (define (transform/quasiquote expression)
  79.   (descend-quasiquote expression 0 finalize-quasiquote))
  80.  
  81. (define (descend-quasiquote x level return)
  82.   (cond ((pair? x) (descend-quasiquote-pair x level return))
  83.     ((vector? x) (descend-quasiquote-vector x level return))
  84.     (else (return 'QUOTE x))))
  85.  
  86. (define (descend-quasiquote-pair x level return)
  87.   (define (descend-quasiquote-pair* level)
  88.     (descend-quasiquote (car x) level
  89.       (lambda (car-mode car-arg)
  90.     (descend-quasiquote (cdr x) level
  91.       (lambda (cdr-mode cdr-arg)
  92.         (cond ((and (eq? car-mode 'QUOTE)
  93.             (eq? cdr-mode 'QUOTE))
  94.            (return 'QUOTE x))
  95.           ((eq? car-mode 'UNQUOTE-SPLICING)
  96.            (if (and (eq? cdr-mode 'QUOTE)
  97.                 (null? cdr-arg))
  98.                (return 'UNQUOTE car-arg)
  99.                (return (make-absolute-reference 'APPEND)
  100.                    (list car-arg
  101.                      (finalize-quasiquote cdr-mode cdr-arg)))))
  102.           ((and (eq? cdr-mode 'QUOTE)
  103.             (null? cdr-arg))
  104.            (return 'LIST
  105.                (list (finalize-quasiquote car-mode car-arg))))
  106.           ((and (eq? cdr-mode 'QUOTE)
  107.             (list? cdr-arg))
  108.            (return 'LIST
  109.                (cons (finalize-quasiquote car-mode car-arg)
  110.                  (map (lambda (el)
  111.                     (finalize-quasiquote 'QUOTE el))
  112.                       cdr-arg))))
  113.           ((memq cdr-mode '(LIST CONS))
  114.            (return cdr-mode
  115.                (cons (finalize-quasiquote car-mode car-arg)
  116.                  cdr-arg)))
  117.           (else
  118.            (return
  119.             'CONS
  120.             (list (finalize-quasiquote car-mode car-arg)
  121.               (finalize-quasiquote cdr-mode cdr-arg))))))))))
  122.   (cond ((and (eq? (car x) 'QUASIQUOTE)
  123.           (pair? (cdr x))
  124.           (null? (cddr x)))
  125.      (descend-quasiquote-pair* (1+ level)))
  126.     ((and (or (eq? (car x) 'UNQUOTE)
  127.           (eq? (car x) 'UNQUOTE-SPLICING))
  128.           (pair? (cdr x))
  129.           (null? (cddr x)))
  130.      (if (zero? level)
  131.          (return (car x) (cadr x))
  132.          (descend-quasiquote-pair* (- level 1))))
  133.     (else
  134.      (descend-quasiquote-pair* level))))
  135.  
  136. (define (descend-quasiquote-vector x level return)
  137.   (descend-quasiquote (vector->list x) level
  138.     (lambda (mode arg)
  139.       (case mode
  140.     ((QUOTE)
  141.      (return 'QUOTE x))
  142.     ((LIST)
  143.      (return (make-absolute-reference 'VECTOR) arg))
  144.     (else
  145.      (return (make-absolute-reference 'LIST->VECTOR)
  146.          (list (finalize-quasiquote mode arg))))))))
  147.  
  148. (define (finalize-quasiquote mode arg)
  149.   (case mode
  150.     ((QUOTE) `',arg)
  151.     ((UNQUOTE) arg)
  152.     ((UNQUOTE-SPLICING) (error ",@ in illegal context" arg))
  153.     ((LIST) `(,(make-absolute-reference 'LIST) ,@arg))
  154.     ((CONS)
  155.      (if (= (length arg) 2)
  156.      `(,(make-absolute-reference 'CONS) ,@arg)
  157.      `(,(make-absolute-reference 'CONS*) ,@arg)))
  158.     (else `(,mode ,@arg))))
  159.  
  160. (define (transform/case expr . clauses)
  161.   (let ((need-temp? (not (symbol? expr))))
  162.     (let ((the-expression (if need-temp? (generate-uninterned-symbol) expr)))
  163.       (define (process-clauses clauses)
  164.     (if (null? clauses)
  165.         '()
  166.         (let ((selector (caar clauses))
  167.           (rest (process-clauses (cdr clauses))))
  168.           (if (null? selector)
  169.           rest
  170.           `((,(cond ((eq? selector 'ELSE)
  171.                  (if (not (null? (cdr clauses)))
  172.                  (error "CASE SYNTAX: ELSE not last clause"
  173.                     clauses))
  174.                  'ELSE)
  175.                 ((pair? selector)
  176.                  (transform selector))
  177.                 (else
  178.                  (single-clause selector)))
  179.              ,@(cdar clauses))
  180.             ,@rest)))))
  181.  
  182.       (define (check-selector selector)
  183.     (or (null? selector)
  184.         (and (eq-testable? (car selector))
  185.          (check-selector (cdr selector)))))
  186.  
  187.       (define (eq-testable? selector)
  188.     (or (symbol? selector)
  189.         (char? selector)        ;**** implementation dependent.
  190.         (fix:fixnum? selector)    ;**** implementation dependent.
  191.         (eq? selector false)
  192.         (eq? selector true)))
  193.  
  194.       (define (single-clause selector)
  195.     `(,(if (eq-testable? selector) 'EQ? 'EQV?) ,the-expression ',selector))
  196.  
  197.       (define (transform selector)
  198.     ;; Optimized for speed in compiled code.
  199.     (cond ((null? (cdr selector))
  200.            (single-clause (car selector)))
  201.           ((null? (cddr selector))
  202.            `(OR ,(single-clause (car selector))
  203.             ,(single-clause (cadr selector))))
  204.           ((null? (cdddr selector))
  205.            `(OR ,(single-clause (car selector))
  206.             ,(single-clause (cadr selector))
  207.             ,(single-clause (caddr selector))))
  208.           ((null? (cddddr selector))
  209.            `(OR ,(single-clause (car selector))
  210.             ,(single-clause (cadr selector))
  211.             ,(single-clause (caddr selector))
  212.             ,(single-clause (cadddr selector))))
  213.           (else
  214.            `(,(if (check-selector selector) 'MEMQ 'MEMV)
  215.          ,the-expression ',selector))))
  216.  
  217.       (let ((body `(COND ,@(process-clauses clauses))))
  218.     (if need-temp?
  219.         `(let ((,the-expression ,expr))
  220.            ,body)
  221.         body)))))
  222.  
  223. (define (transform/let* bindings . body)
  224.   (guarantee-let-bindings bindings 'LET* #f)
  225.   (define (do-one bindings)
  226.     (if (null? bindings)
  227.     `(BEGIN ,@body)
  228.     `(LET (,(car bindings))
  229.        ,(do-one (cdr bindings)))))
  230.   (if (null? bindings)
  231.       `(LET () ,@body)            ; To allow internal definitions
  232.       (do-one bindings)))
  233.  
  234. (define (transform/letrec bindings . body)
  235.   (guarantee-let-bindings bindings 'LETREC #f)
  236.   `(LET ()
  237.      ,@(map (lambda (binding) `(DEFINE ,@binding)) bindings)
  238.      (LET ()                ; Internal definitions must be in
  239.                     ; nested contour.
  240.        ,@body)))
  241.  
  242. (define (transform/do bindings test . body)
  243.   (guarantee-let-bindings bindings 'DO #t)
  244.   (let ((the-name (string->uninterned-symbol "do-loop")))
  245.     `(LET ,the-name
  246.       ,(map (lambda (binding)
  247.           (if (or (null? (cdr binding))
  248.               (null? (cddr binding)))
  249.               binding
  250.               `(,(car binding) ,(cadr binding))))
  251.         bindings)
  252.        ,(process-cond-clause test false
  253.       `(BEGIN
  254.          ,@body
  255.          (,the-name ,@(map (lambda (binding)
  256.                  (if (or (null? (cdr binding))
  257.                      (null? (cddr binding)))
  258.                      (car binding)
  259.                      (caddr binding)))
  260.                    bindings)))))))
  261.  
  262. (define (guarantee-let-bindings bindings keyword do-like?)
  263.   (if (not (and (list? bindings)
  264.         (for-all? bindings
  265.           (lambda (binding)
  266.             (and (list? binding)
  267.              (not (null? binding))
  268.              (symbol? (car binding))
  269.              (or (null? (cdr binding))
  270.                  (null? (cddr binding))
  271.                  (and do-like? (null? (cdddr binding)))))))))
  272.       (error "SYNTAX: Bad bindings:" keyword bindings)))
  273.  
  274. (define (process-cond-clause clause else-permitted? rest)
  275.   (if (or (null? clause) (not (list? clause)))
  276.       (error "cond-clause syntax: not a non-empty list:" clause))
  277.   (cond ((eq? 'ELSE (car clause))
  278.      (if (not else-permitted?)
  279.          (error "cond-clause syntax: ELSE not permitted:" clause))
  280.      (if (null? (cdr clause))
  281.          (error "cond-clause syntax: ELSE missing expressions:" clause))
  282.      `(BEGIN ,@(cdr clause)))
  283.     ((null? (cdr clause))
  284.      `(OR ,(car clause) ,rest))
  285.     ((eq? '=> (cadr clause))
  286.      (if (null? (cddr clause))
  287.          (error "cond-clause syntax: => missing recipient:" clause))
  288.      (if (not (null? (cdddr clause)))
  289.          (error "cond-clause syntax: misformed => clause:" clause))
  290.      (let ((predicate (string->uninterned-symbol "predicate")))
  291.        `(LET ((,predicate ,(car clause)))
  292.           (IF ,predicate
  293.           (,(caddr clause) ,predicate)
  294.           ,rest))))
  295.     (else
  296.      (if (null? (cdr clause))
  297.          (error "cond-clause syntax: missing expressions:" clause))
  298.      `(IF ,(car clause)
  299.           (BEGIN ,@(cdr clause))
  300.           ,rest))))
  301.  
  302. (define transform/define-integrable
  303.   (macro (pattern . body)
  304.     (parse-define-syntax pattern body
  305.       (lambda (name body)
  306.     `(BEGIN (DECLARE (INTEGRATE ,pattern))
  307.         (DEFINE ,name ,@body)))
  308.       (lambda (pattern body)
  309.     `(BEGIN (DECLARE (INTEGRATE-OPERATOR ,(car pattern)))
  310.         (DEFINE ,pattern
  311.           ,@(if (list? (cdr pattern))
  312.             `((DECLARE
  313.                (INTEGRATE
  314.                 ,@(lambda-list->bound-names (cdr pattern)))))
  315.             '())
  316.           ,@body))))))
  317.  
  318. (define (parse-define-syntax pattern body if-variable if-lambda)
  319.   (cond ((pair? pattern)
  320.      (let loop ((pattern pattern) (body body))
  321.        (cond ((pair? (car pattern))
  322.           (loop (car pattern) `((LAMBDA ,(cdr pattern) ,@body))))
  323.          ((symbol? (car pattern))
  324.           (if-lambda pattern body))
  325.          (else
  326.           (error "Illegal name" (car pattern))))))
  327.     ((symbol? pattern)
  328.      (if-variable pattern body))
  329.     (else
  330.      (error "Illegal name" pattern))))
  331.  
  332. (define (lambda-list->bound-names lambda-list)
  333.   (cond ((null? lambda-list)
  334.      '())
  335.     ((pair? lambda-list)
  336.      (let ((lambda-list
  337.         (if (eq? (car lambda-list) lambda-optional-tag)
  338.             (begin (if (not (pair? (cdr lambda-list)))
  339.                    (error "Missing optional variable" lambda-list))
  340.                (cdr lambda-list))
  341.             lambda-list)))
  342.        (cons (let ((parameter (car lambda-list)))
  343.            (if (pair? parameter) (car parameter) parameter))
  344.          (lambda-list->bound-names (cdr lambda-list)))))
  345.     (else
  346.      (if (not (symbol? lambda-list))
  347.          (error "Illegal rest variable" lambda-list))
  348.      (list lambda-list))))