home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / scheme / pseudo-s / pseudo_2.lha / derive.scm < prev    next >
Encoding:
Text File  |  1991-06-21  |  5.5 KB  |  215 lines
  1. ; -*- Mode: Scheme; Syntax: Scheme; Package: Scheme; -*-
  2. ; File derive.scm / Copyright (c) 1991 Jonathan Rees / See file COPYING
  3.  
  4. ;;;; Macro expanders for standard derived expression types
  5.  
  6. (define (define-usual-syntax name expander)
  7.   (program-env-define! revised^4-scheme-env
  8.                name
  9.                (make-macro (lambda (form r c)
  10.                      (apply expander r c (cdr form)))
  11.                    revised^4-scheme-env)))
  12.  
  13. ; syntax-rules is defined elsewhere
  14.  
  15. (program-env-define! revised^4-scheme-env
  16.              'syntax-rules
  17.              (make-macro rewrite-syntax-rules revised^4-scheme-env))
  18.  
  19. ; The expanders:
  20. ;  r = rename
  21. ;  c = compare
  22.  
  23. (define-usual-syntax 'and
  24.   (lambda (r c . conjuncts)
  25.     c ;ignored
  26.     (if (null? conjuncts)
  27.     #t
  28.     (let recur ((first (car conjuncts)) (rest (cdr conjuncts)))
  29.       (if (null? rest)
  30.           first
  31.           `(,(r 'and-aux) ,first
  32.           (,(r 'lambda) () ,(recur (car rest) (cdr rest)))))))))
  33.  
  34. (define-usual-syntax 'or
  35.   (lambda (r c . disjuncts)
  36.     c ;ignored
  37.     (if (null? disjuncts)
  38.     #f
  39.     (let recur ((first (car disjuncts)) (rest (cdr disjuncts)))
  40.       (if (null? rest)
  41.           first
  42.           `(,(r 'or-aux) ,first
  43.           (,(r 'lambda) () ,(recur (car rest) (cdr rest)))))))))
  44.  
  45.  
  46. ; (case key ((a b) x) ((c) y) (else z))
  47. ;  ==>  (case-aux key
  48. ;          '((a b) (c))
  49. ;          (lambda () z)
  50. ;          (lambda () x)
  51. ;          (lambda () y))
  52.  
  53. (define-usual-syntax 'case
  54.   (lambda (r c key . clauses)
  55.     (let ((form-result
  56.        (lambda (else-thunk thunks key-lists)
  57.          `(,(r 'case-aux) ,key
  58.             (,(r 'quote) ,(reverse key-lists))
  59.             ,else-thunk
  60.             ,@(reverse thunks)))))
  61.       (let loop ((cs clauses) (thunks '()) (key-lists '()))
  62.     (if (null? cs)
  63.         (form-result `(,(r 'lambda) () ,(r 'unspecified))
  64.              thunks key-lists)
  65.         (let* ((clause (car cs))
  66.            (key-list (car clause))
  67.            (body (cdr clause)))
  68.           (if (c key-list (r 'else))
  69.           (form-result `(,(r 'lambda) () ,@body) thunks key-lists)
  70.           (loop (cdr cs)
  71.             (cons `(,(r 'lambda) () ,@body) thunks)
  72.             (cons key-list key-lists)))))))))
  73.  
  74. (define-usual-syntax 'cond
  75.   (lambda (r c . clauses)
  76.     (let recur ((clauses clauses))
  77.       (if (null? clauses)
  78.       (r 'unspecified)
  79.       (process-cond-clause r c
  80.                    (car clauses)
  81.                    (recur (cdr clauses)))))))
  82.  
  83. ; Auxiliary also used by DO
  84.  
  85. (define (process-cond-clause r c clause rest)
  86.   (cond ((null? (cdr clause))
  87.      `(,(r 'or-aux) ,(car clause)
  88.           (,(r 'lambda) () ,rest)))
  89.     ((c (car clause) (r 'else))
  90.      `(,(r 'begin) ,@(cdr clause)))
  91.     ((c (cadr clause) (r '=>))
  92.      `(,(r '=>-aux) ,(car clause)
  93.           (,(r 'lambda) () ,(caddr clause))
  94.           (,(r 'lambda) () ,rest)))
  95.     (else
  96.      `(,(r 'if) ,(car clause)
  97.           (,(r 'begin) ,@(cdr clause))
  98.           ,rest))))
  99.  
  100. (define-usual-syntax 'delay
  101.   (lambda (r c thing)
  102.     c ;ignored
  103.     `(,(r 'make-promise) (,(r 'lambda) () ,thing))))
  104.  
  105. (define-usual-syntax 'do
  106.   (lambda (r c specs end . body)
  107.     c ;ignored
  108.     (let ((loop (r 'loop)))
  109.       `(,(r 'letrec) ((,loop
  110.                (,(r 'lambda)
  111.             ,(map car specs)
  112.             ,(process-cond-clause
  113.               r c
  114.               end
  115.               `(,(r 'begin) ,@body
  116.                     (,loop ,@(map (lambda (y)
  117.                             (if (null? (cddr y))
  118.                                 (car y)
  119.                                 (caddr y)))
  120.                               specs)))))))
  121.              (,loop ,@(map cadr specs))))))
  122.  
  123. (define-usual-syntax 'let
  124.   (lambda (r c specs . body)
  125.     c ;ignored
  126.     (cond ((name? specs)
  127.        (let ((tag specs)
  128.          (specs (car body))
  129.          (body (cdr body)))
  130.          `(,(r 'letrec) ((,tag (,(r 'lambda) ,(map car specs) ,@body)))
  131.                 (,tag ,@(map cadr specs)))))
  132.       (else
  133.        `((,(r 'lambda) ,(map car specs) ,@body)
  134.          ,@(map cadr specs))))))
  135.  
  136. (define-usual-syntax 'let*
  137.   (lambda (r c specs . body)
  138.     c ;ignored
  139.     (let recur ((specs specs))
  140.       (if (null? specs)
  141.       `(,(r 'begin) ,@body)
  142.       (let ((name (car (car specs)))
  143.         (val-exp (cadr (car specs))))
  144.         `(,(r 'let) ((,name ,val-exp))
  145.            ,(recur (cdr specs))))))))
  146.  
  147. ;;;; Quasiquote
  148.  
  149. (define-usual-syntax 'quasiquote
  150.   (lambda (r c x)
  151.     c ;ignored
  152.     (qq-descend x 1 r)))
  153.  
  154. (define (qq-descend x level r)
  155.   (cond ((vector? x)
  156.      (qq-descend-vector x level r))
  157.     ((not (pair? x))
  158.      (make-quotation x r))
  159.     ((qq-interesting? x 'quasiquote)
  160.      (qq-descend-pair x (+ level 1) r))
  161.     ((qq-interesting? x 'unquote)
  162.      (if (= level 1)
  163.          (cadr x)
  164.          (qq-descend-pair x (- level 1) r)))
  165.     ((qq-interesting? x 'unquote-splicing)
  166.      (if (= level 1)
  167.          (error ",@ in illegal position" x)
  168.          (qq-descend-pair x (- level 1) r)))
  169.         (else
  170.      (qq-descend-pair x level r))))
  171.  
  172. (define (qq-descend-pair x level r)
  173.   (let ((d-exp (qq-descend (cdr x) level r)))
  174.     (if (and (qq-interesting? (car x) 'unquote-splicing)
  175.          (= level 1))
  176.     (let ((sc (cadr (car x))))
  177.       (cond ((and (quotation? d-exp r)
  178.               (null? (quotation-value d-exp)))
  179.          sc)
  180.         (else
  181.          `(,(r 'append) ,sc ,d-exp))))
  182.     (let ((a-exp (qq-descend (car x) level r)))
  183.       (cond ((and (quotation? a-exp r)
  184.               (quotation? d-exp r))
  185.          (make-quotation x r))
  186.         ((and (quotation? d-exp r)
  187.               (eq? (quotation-value d-exp) '()))
  188.          `(,(r 'list) ,a-exp))
  189.         ((qq-interesting? d-exp 'list)
  190.          `(,(r 'list) ,a-exp ,@(cdr d-exp)))
  191.         ;;+++ Ought to use auxiliary CONS* procedure, for more
  192.         ;; readable output
  193.         (else
  194.          `(,(r 'cons) ,a-exp ,d-exp)))))))
  195.  
  196. (define (qq-descend-vector x level r)
  197.   (let ((result (qq-descend (vector->list x) level r)))
  198.     (if (quotation? result r)
  199.     (make-quotation x r)
  200.     `(,(r 'list->vector) ,result))))
  201.  
  202. (define (qq-interesting? x marker)
  203.   (and (pair? x)
  204.        (eq? (car x) marker)
  205.        (pair? (cdr x))
  206.        (null? (cddr x))))
  207.  
  208. (define (quotation? x r)
  209.   (qq-interesting? x (r 'quote)))
  210.  
  211. (define quotation-value cadr)
  212.  
  213. (define (make-quotation value r)
  214.   `(,(r 'quote) ,value))
  215.