home *** CD-ROM | disk | FTP | other *** search
/ Dream 44 / Amiga_Dream_44.iso / RiscPc / programmation / scm4e2.arc / !Scm / slib / mwexpand < prev    next >
Text File  |  1994-06-21  |  18KB  |  549 lines
  1. ;"mwexpand.scm" macro expander
  2. ; Copyright 1992 William Clinger
  3. ;
  4. ; Permission to copy this software, in whole or in part, to use this
  5. ; software for any lawful purpose, and to redistribute this software
  6. ; is granted subject to the restriction that all copies made of this
  7. ; software must include this copyright notice in full.
  8. ;
  9. ; I also request that you send me a copy of any improvements that you
  10. ; make to this software so that they may be incorporated within it to
  11. ; the benefit of the Scheme community.
  12.  
  13. ; The external entry points and kernel of the macro expander.
  14. ;
  15. ; Part of this code is snarfed from the Twobit macro expander.
  16.  
  17. (define mw:define-syntax-scope
  18.   (let ((flag 'letrec))
  19.     (lambda args
  20.       (cond ((null? args) flag)
  21.         ((not (null? (cdr args)))
  22.          (apply mw:warn
  23.             "Too many arguments passed to define-syntax-scope"
  24.             args))
  25.         ((memq (car args) '(letrec letrec* let*))
  26.          (set! flag (car args)))
  27.         (else (mw:warn "Unrecognized argument to define-syntax-scope"
  28.               (car args)))))))
  29.  
  30. (define mw:quit             ; assigned by macwork:expand
  31.   (lambda (v) v))
  32.  
  33. (define (macwork:expand def-or-exp)
  34.   (call-with-current-continuation
  35.    (lambda (k)
  36.      (set! mw:quit k)
  37.      (set! mw:renaming-counter 0)
  38.      (mw:desugar-definitions def-or-exp mw:global-syntax-environment))))
  39.  
  40. (define (mw:desugar-definitions exp env)
  41.   (letrec 
  42.     ((define-loop 
  43.        (lambda (exp rest first)
  44.      (cond ((and (pair? exp)
  45.              (eq? (mw:syntax-lookup env (car exp))
  46.               mw:denote-of-begin)
  47.              (pair? (cdr exp)))
  48.         (define-loop (cadr exp) (append (cddr exp) rest) first))
  49.            ((and (pair? exp)
  50.              (eq? (mw:syntax-lookup env (car exp))
  51.               mw:denote-of-define))
  52.         (let ((exp (desugar-define exp env)))
  53.           (cond ((and (null? first) (null? rest))
  54.              exp)
  55.             ((null? rest)
  56.              (cons mw:begin1 (reverse (cons exp first))))
  57.             (else (define-loop (car rest)
  58.                        (cdr rest)
  59.                        (cons exp first))))))
  60.            ((and (pair? exp)
  61.              (eq? (mw:syntax-lookup env (car exp))
  62.               mw:denote-of-define-syntax)
  63.              (null? first))
  64.         (define-syntax-loop exp rest))
  65.            ((and (null? first) (null? rest))
  66.         (mw:expand exp env))
  67.            ((null? rest)
  68.         (cons mw:begin1 (reverse (cons (mw:expand exp env) first))))
  69.            (else (cons mw:begin1
  70.                (append (reverse first)
  71.                    (map (lambda (exp) (mw:expand exp env))
  72.                     (cons exp rest))))))))
  73.      
  74.      (desugar-define
  75.       (lambda (exp env)
  76.     (cond 
  77.      ((null? (cdr exp)) (mw:error "Malformed definition" exp))
  78.      ; (define foo) syntax is transformed into (define foo (undefined)).
  79.      ((null? (cddr exp))
  80.       (let ((id (cadr exp)))
  81.         (redefinition id)
  82.         (mw:syntax-bind-globally! id (mw:make-identifier-denotation id))
  83.         (list mw:define1 id mw:undefined)))
  84.      ((pair? (cadr exp))
  85.       ; mw:lambda0 is an unforgeable lambda, needed here because the
  86.       ; lambda expression will undergo further expansion.
  87.       (desugar-define `(,mw:define1 ,(car (cadr exp))
  88.                      (,mw:lambda0 ,(cdr (cadr exp))
  89.                            ,@(cddr exp)))
  90.               env))
  91.      ((> (length exp) 3) (mw:error "Malformed definition" exp))
  92.      (else (let ((id (cadr exp)))
  93.          (redefinition id)
  94.          (mw:syntax-bind-globally! id (mw:make-identifier-denotation id))
  95.          `(,mw:define1 ,id ,(mw:expand (caddr exp) env)))))))
  96.      
  97.      (define-syntax-loop 
  98.        (lambda (exp rest)
  99.      (cond ((and (pair? exp)
  100.              (eq? (mw:syntax-lookup env (car exp))
  101.               mw:denote-of-begin)
  102.              (pair? (cdr exp)))
  103.         (define-syntax-loop (cadr exp) (append (cddr exp) rest)))
  104.            ((and (pair? exp)
  105.              (eq? (mw:syntax-lookup env (car exp))
  106.               mw:denote-of-define-syntax))
  107.         (if (pair? (cdr exp))
  108.             (redefinition (cadr exp)))
  109.         (if (null? rest)
  110.             (mw:define-syntax exp env)
  111.             (begin (mw:define-syntax exp env)
  112.                (define-syntax-loop (car rest) (cdr rest)))))
  113.            ((null? rest)
  114.         (mw:expand exp env))
  115.            (else (cons mw:begin1
  116.                (map (lambda (exp) (mw:expand exp env))
  117.                     (cons exp rest)))))))
  118.      
  119.      (redefinition
  120.       (lambda (id)
  121.     (if (symbol? id)
  122.         (if (not (mw:identifier?
  123.               (mw:syntax-lookup mw:global-syntax-environment id)))
  124.         (mw:warn "Redefining keyword" id))
  125.         (mw:error "Malformed variable or keyword" id)))))
  126.     
  127.     ; body of letrec
  128.     
  129.     (define-loop exp '() '())))
  130.  
  131. ; Given an expression and a syntactic environment,
  132. ; returns an expression in core Scheme.
  133.  
  134. (define (mw:expand exp env)
  135.   (if (not (pair? exp))
  136.       (mw:atom exp env)
  137.       (let ((keyword (mw:syntax-lookup env (car exp))))
  138.     (case (mw:denote-class keyword)
  139.       ((special)
  140.        (cond
  141.         ((eq? keyword mw:denote-of-quote)         (mw:quote exp))
  142.         ((eq? keyword mw:denote-of-lambda)        (mw:lambda exp env))
  143.         ((eq? keyword mw:denote-of-if)            (mw:if exp env))
  144.         ((eq? keyword mw:denote-of-set!)          (mw:set exp env))
  145.         ((eq? keyword mw:denote-of-begin)         (mw:begin exp env))
  146.         ((eq? keyword mw:denote-of-let-syntax)    (mw:let-syntax exp env))
  147.         ((eq? keyword mw:denote-of-letrec-syntax)
  148.          (mw:letrec-syntax exp env))
  149.         ; @@ let, let*, letrec, paint within quasiquotation -- kend
  150.         ((eq? keyword mw:denote-of-let)           (mw:let    exp env))
  151.         ((eq? keyword mw:denote-of-let*)          (mw:let*   exp env))
  152.         ((eq? keyword mw:denote-of-letrec)        (mw:letrec exp env))
  153.         ((eq? keyword mw:denote-of-quasiquote)    (mw:quasiquote exp env))
  154.         ((eq? keyword mw:denote-of-do)            (mw:do     exp env))
  155.         ((or (eq? keyword mw:denote-of-define)
  156.          (eq? keyword mw:denote-of-define-syntax))
  157.          ;; slight hack to allow expansion into defines -KenD
  158.          (if mw:in-define? 
  159.            (mw:error "Definition out of context" exp)
  160.            (begin
  161.          (set! mw:in-define? #t)
  162.          (let ( (result (mw:desugar-definitions exp env)) )
  163.            (set! mw:in-define? #f)
  164.            result))
  165.         ))
  166.         (else (mw:bug "Bug detected in mw:expand" exp env))))
  167.       ((macro) (mw:macro exp env))
  168.       ((identifier) (mw:application exp env))
  169.       (else (mw:bug "Bug detected in mw:expand" exp env))
  170.       ) )
  171. ) )
  172.  
  173. (define mw:in-define? #f)  ; should be fluid
  174.  
  175. (define (mw:atom exp env)
  176.   (cond ((not (symbol? exp))
  177.      ; Here exp ought to be a boolean, number, character, or string,
  178.      ; but I'll allow for non-standard extensions by passing exp
  179.      ; to the underlying Scheme system without further checking.
  180.      exp)
  181.     (else (let ((denotation (mw:syntax-lookup env exp)))
  182.         (case (mw:denote-class denotation)
  183.           ((special macro)
  184.            (mw:error "Syntactic keyword used as a variable" exp env))
  185.           ((identifier) (mw:identifier-name denotation))
  186.           (else (mw:bug "Bug detected by mw:atom" exp env)))))))
  187.  
  188. (define (mw:quote exp)
  189.   (if (= (mw:safe-length exp) 2)
  190.       (list mw:quote1 (mw:strip (cadr exp)))
  191.       (mw:error "Malformed quoted constant" exp)))
  192.  
  193. (define (mw:lambda exp env)
  194.   (if (> (mw:safe-length exp) 2)
  195.       (let* ((formals (cadr exp))
  196.          (alist (mw:rename-vars (mw:make-null-terminated formals)))
  197.          (env (mw:syntax-rename env alist))
  198.          (body (cddr exp)))
  199.     (list mw:lambda1
  200.           (mw:rename-formals formals alist)
  201.           (mw:body body env)))
  202.       (mw:error "Malformed lambda expression" exp)))
  203.  
  204. (define (mw:body body env)
  205.   (define (loop body env defs)
  206.     (if (null? body)
  207.     (mw:error "Empty body"))
  208.     (let ((exp (car body)))
  209.       (if (and (pair? exp)
  210.            (symbol? (car exp)))
  211.       (let ((denotation (mw:syntax-lookup env (car exp))))
  212.         (case (mw:denote-class denotation)
  213.           ((special)
  214.            (cond ((eq? denotation mw:denote-of-begin)
  215.               (loop (append (cdr exp) (cdr body)) env defs))
  216.              ((eq? denotation mw:denote-of-define)
  217.               (loop (cdr body) env (cons exp defs)))
  218.              (else (mw:finalize-body body env defs))))
  219.           ((macro)
  220.            (mw:transcribe exp
  221.                  env
  222.                  (lambda (exp env)
  223.                    (loop (cons exp (cdr body))
  224.                      env
  225.                      defs))))
  226.           ((identifier)
  227.            (mw:finalize-body body env defs))
  228.           (else (mw:bug "Bug detected in mw:body" body env))))
  229.       (mw:finalize-body body env defs))))
  230.   (loop body env '()))
  231.  
  232. (define (mw:finalize-body body env defs)
  233.   (if (null? defs)
  234.       (let ((body (map (lambda (exp) (mw:expand exp env))
  235.                body)))
  236.     (if (null? (cdr body))
  237.         (car body)
  238.         (cons mw:begin1 body)))
  239.       (let* ((alist (mw:rename-vars '(quote lambda set!)))
  240.          (env (mw:syntax-alias env alist mw:standard-syntax-environment))
  241.          (new-quote  (cdr (assq 'quote alist)))
  242.          (new-lambda (cdr (assq 'lambda alist)))
  243.          (new-set!   (cdr (assq 'set!   alist))))
  244.     (define (desugar-definition def)
  245.       (if (> (mw:safe-length def) 2)
  246.           (cond ((pair? (cadr def))
  247.              (desugar-definition
  248.               `(,(car def)
  249.             ,(car (cadr def))
  250.             (,new-lambda
  251.               ,(cdr (cadr def))
  252.               ,@(cddr def)))))
  253.             ((= (length def) 3)
  254.              (cdr def))
  255.             (else (mw:error "Malformed definition" def env)))
  256.           (mw:error "Malformed definition" def env)))
  257.     (mw:letrec
  258.      `(letrec ,(map desugar-definition (reverse defs)) ,@body)
  259.       env)))
  260.   )
  261.  
  262. (define (mw:if exp env)
  263.   (let ((n (mw:safe-length exp)))
  264.     (if (or (= n 3) (= n 4))
  265.     (cons mw:if1 (map (lambda (exp) (mw:expand exp env)) (cdr exp)))
  266.     (mw:error "Malformed if expression" exp env))))
  267.  
  268. (define (mw:set exp env)
  269.   (if (= (mw:safe-length exp) 3)
  270.       `(,mw:set!1 ,(mw:expand (cadr exp) env) ,(mw:expand (caddr exp) env))
  271.       (mw:error "Malformed assignment" exp env)))
  272.  
  273. (define (mw:begin exp env)
  274.   (if (positive? (mw:safe-length exp))
  275.       `(,mw:begin1 ,@(map (lambda (exp) (mw:expand exp env)) (cdr exp)))
  276.       (mw:error "Malformed begin expression" exp env)))
  277.  
  278. (define (mw:application exp env)
  279.   (if (> (mw:safe-length exp) 0)
  280.       (map (lambda (exp) (mw:expand exp env))
  281.        exp)
  282.       (mw:error "Malformed application")))
  283.  
  284. ; I think the environment argument should always be global here.
  285.  
  286. (define (mw:define-syntax exp env)
  287.   (cond ((and (= (mw:safe-length exp) 3)
  288.           (symbol? (cadr exp)))
  289.      (mw:define-syntax1 (cadr exp)
  290.                (caddr exp)
  291.                env
  292.                (mw:define-syntax-scope)))
  293.     ((and (= (mw:safe-length exp) 4)
  294.           (symbol? (cadr exp))
  295.           (memq (caddr exp) '(letrec letrec* let*)))
  296.      (mw:define-syntax1 (cadr exp)
  297.                (cadddr exp)
  298.                env
  299.                (caddr exp)))
  300.     (else (mw:error "Malformed define-syntax" exp env))))
  301.  
  302. (define (mw:define-syntax1 keyword spec env scope)
  303.   (case scope
  304.     ((letrec)  (mw:define-syntax-letrec keyword spec env))
  305.     ((letrec*) (mw:define-syntax-letrec* keyword spec env))
  306.     ((let*)    (mw:define-syntax-let* keyword spec env))
  307.     (else      (mw:bug "Weird scope" scope)))
  308.   (list mw:quote1 keyword))
  309.  
  310. (define (mw:define-syntax-letrec keyword spec env)
  311.   (mw:syntax-bind-globally!
  312.    keyword
  313.    (mw:compile-transformer-spec spec env)))
  314.  
  315. (define (mw:define-syntax-letrec* keyword spec env)
  316.   (let* ((env (mw:syntax-extend (mw:syntax-copy env)
  317.                 (list keyword)
  318.                 '((fake denotation))))
  319.      (transformer (mw:compile-transformer-spec spec env)))
  320.     (mw:syntax-assign! env keyword transformer)
  321.     (mw:syntax-bind-globally! keyword transformer)))
  322.  
  323. (define (mw:define-syntax-let* keyword spec env)
  324.   (mw:syntax-bind-globally!
  325.    keyword
  326.    (mw:compile-transformer-spec spec (mw:syntax-copy env))))
  327.  
  328. (define (mw:let-syntax exp env)
  329.   (if (and (> (mw:safe-length exp) 2)
  330.        (comlist:every (lambda (binding)
  331.             (and (pair? binding)
  332.              (symbol? (car binding))
  333.              (pair? (cdr binding))
  334.              (null? (cddr binding))))
  335.             (cadr exp)))
  336.       (mw:body (cddr exp)
  337.           (mw:syntax-extend env
  338.                 (map car (cadr exp))
  339.                 (map (lambda (spec)
  340.                        (mw:compile-transformer-spec
  341.                     spec
  342.                     env))
  343.                      (map cadr (cadr exp)))))
  344.       (mw:error "Malformed let-syntax" exp env)))
  345.  
  346. (define (mw:letrec-syntax exp env)
  347.   (if (and (> (mw:safe-length exp) 2)
  348.        (comlist:every (lambda (binding)
  349.             (and (pair? binding)
  350.              (symbol? (car binding))
  351.              (pair? (cdr binding))
  352.              (null? (cddr binding))))
  353.             (cadr exp)))
  354.       (let ((env (mw:syntax-extend env
  355.                    (map car (cadr exp))
  356.                    (map (lambda (id)
  357.                       '(fake denotation))
  358.                     (cadr exp)))))
  359.     (for-each (lambda (id spec)
  360.             (mw:syntax-assign!
  361.              env
  362.              id
  363.              (mw:compile-transformer-spec spec env)))
  364.           (map car (cadr exp))
  365.           (map cadr (cadr exp)))
  366.     (mw:body (cddr exp) env))
  367.       (mw:error "Malformed let-syntax" exp env)))
  368.  
  369. (define (mw:macro exp env)
  370.   (mw:transcribe exp
  371.         env
  372.         (lambda (exp env)
  373.           (mw:expand exp env))))
  374.  
  375. ; To do:
  376. ; Clean up alist hacking et cetera.
  377.  
  378. ;;-----------------------------------------------------------------
  379. ;; The following was added to allow expansion without flattening 
  380. ;; LETs to LAMBDAs so that the origianl structure of the program 
  381. ;; is preserved by macro expansion.  I.e. so that usual.scm is not 
  382. ;; required. -- added KenD 
  383.  
  384. (define (mw:process-let-bindings alist binding-list env)  ;; helper proc
  385.   (map (lambda (bind)
  386.      (list (cdr (assq (car bind) alist)) ; renamed name
  387.            (mw:body (cdr bind) env)))     ; alpha renamed value expression
  388.        binding-list)
  389. )
  390.  
  391. (define (mw:strip-begin exp) ;; helper proc: mw:body sometimes puts one in
  392.   (if (and (pair? exp) (eq? (car exp) 'begin))
  393.     (cdr exp)
  394.     exp)
  395. )
  396.  
  397. ; LET
  398. (define (mw:let exp env)
  399.   (let* ( (name (if (or (pair? (cadr exp)) (null? (cadr exp)))
  400.             #f 
  401.             (cadr exp)))  ; named let?
  402.       (binds (if name (caddr exp) (cadr exp)))
  403.       (body  (if name (cdddr exp) (cddr exp)))
  404.       (vars  (if (null? binds) #f (map car binds)))
  405.       (alist (if vars (mw:rename-vars vars) #f))
  406.       (newenv (if alist (mw:syntax-rename env alist) env))
  407.     )
  408.     (if name  ;; extend env with new name
  409.     (let ( (rename (mw:rename-vars (list name))) )
  410.       (set! alist (append rename alist))
  411.       (set! newenv (mw:syntax-rename newenv rename))
  412.     )   )
  413.     `(let
  414.      ,@(if name (list (cdr (assq name alist))) '())
  415.      ,(mw:process-let-bindings alist binds env)
  416.      ,(mw:body body newenv))
  417. ) )
  418.  
  419.  
  420. ; LETREC differs from LET in that the binding values are processed in the
  421. ; new rather than the original environment.
  422.  
  423. (define (mw:letrec exp env)
  424.   (let* ( (binds (cadr exp))
  425.       (body  (cddr exp))
  426.       (vars  (if (null? binds) #f (map car binds)))
  427.       (alist (if vars (mw:rename-vars vars) #f))
  428.       (newenv (if alist (mw:syntax-rename env alist) env))
  429.     )
  430.     `(letrec
  431.       ,(mw:process-let-bindings alist binds newenv)
  432.       ,(mw:body body newenv))
  433. ) )
  434.  
  435.  
  436. ; LET* adds to ENV for each new binding.
  437.  
  438. (define (mw:let* exp env)
  439.   (let ( (binds (cadr exp))
  440.      (body  (cddr exp))
  441.        )
  442.     (let bind-loop ( (bindings binds) (newbinds '()) (newenv env) )
  443.        (if (null? bindings)
  444.       `(let* ,(reverse newbinds) ,(mw:body body newenv))
  445.        (let* ( (bind (car bindings))
  446.            (var    (car bind)) 
  447.            (valexp (cdr bind))
  448.            (rename (mw:rename-vars (list var)))
  449.            (next-newenv (mw:syntax-rename newenv rename))
  450.          )
  451.          (bind-loop (cdr bindings) 
  452.             (cons (list (cdr (assq var rename))
  453.                     (mw:body valexp newenv))
  454.                   newbinds)
  455.             next-newenv))
  456. ) ) ) )
  457.  
  458.  
  459. ; DO
  460.  
  461. (define (mw:process-do-bindings var-init-steps alist oldenv newenv)  ;; helper proc
  462.   (map (lambda (vis)
  463.      (let ( (v (car vis))
  464.         (i (cadr vis))
  465.         (s (if (null? (cddr vis)) (car vis) (caddr vis))))
  466.        `( ,(cdr (assq v alist)) ; renamed name
  467.           ,(mw:body (list i) oldenv)     ; init in outer/old env
  468.           ,(mw:body (list s) newenv) ))) ; step in letrec/inner/new env
  469.        var-init-steps)
  470. )
  471.  
  472. (define (mw:do exp env)
  473.   (let* ( (vis  (cadr exp))  ; (Var Init Step ...)
  474.       (ts   (caddr exp)) ; (Test Sequence ...)
  475.       (com  (cdddr exp)) ; (COMmand ...)
  476.       (vars (if (null? vis) #f (map car vis)))
  477.       (rename (if vars (mw:rename-vars vars) #f))
  478.       (newenv (if vars (mw:syntax-rename env rename) env))
  479.     )
  480.     `(do ,(if vars (mw:process-do-bindings vis rename env newenv) '())
  481.      ,(if  (null? ts)  '() (mw:strip-begin (mw:body (list ts) newenv)))
  482.      ,@(if (null? com) '() (list (mw:body com newenv))))
  483. ) )
  484.  
  485. ;
  486. ; Quasiquotation (backquote)           
  487. ;
  488. ; At level 0, unquoted forms are left painted (not mw:strip'ed).
  489. ; At higher levels, forms which are unquoted to level 0 are painted.
  490. ; This includes forms within quotes.  E.g.:
  491. ;   (lambda (a) 
  492. ;     (quasiquote 
  493. ;       (a (unquote a) b (quasiquote (a (unquote (unquote a)) b)))))
  494. ;or equivalently:
  495. ;  (lambda (a) `(a ,a b `(a ,,a b)))
  496. ;=>
  497. ;  (lambda (a|1) `(a ,a|1 b `(a ,,a|1 b)))
  498.  
  499. (define (mw:quasiquote exp env)
  500.  
  501.   (define (mw:atom exp env)
  502.     (if (not (symbol? exp))
  503.     exp
  504.     (let ((denotation (mw:syntax-lookup env exp)))
  505.       (case (mw:denote-class denotation)
  506.         ((special macro identifier) (mw:identifier-name denotation))
  507.         (else (mw:bug "Bug detected by mw:atom" exp env))))
  508.   ) )
  509.  
  510.   (define (quasi subexp level)
  511.      (cond
  512.     ((null? subexp) subexp)
  513.     ((not (or (pair? subexp) (vector? subexp)))
  514.      (if (zero? level) (mw:atom subexp env) subexp) ; the work is here
  515.     )
  516.     ((vector? subexp)
  517.      (let* ((l (vector-length subexp))
  518.         (v (make-vector l)))
  519.        (do ((i 0 (+ i 1)))
  520.            ((= i l) v)
  521.          (vector-set! v i (quasi (vector-ref subexp i) level))
  522.          )
  523.        )
  524.      )
  525.     (else
  526.       (let ( (keyword (mw:syntax-lookup env (car subexp))) )
  527.         (cond
  528.           ((eq? keyword mw:denote-of-unquote)
  529.            (cons 'unquote (quasi (cdr subexp) (- level 1)))
  530.           )
  531.           ((eq? keyword mw:denote-of-unquote-splicing)
  532.            (cons 'unquote-splicing (quasi (cdr subexp) (- level 1)))
  533.           )
  534.           ((eq? keyword mw:denote-of-quasiquote)
  535.            (cons 'quasiquote (quasi (cdr subexp) (+ level 1)))
  536.           )
  537.           (else 
  538.            (cons (quasi (car subexp) level) (quasi (cdr subexp) level)) 
  539.           )
  540.         )
  541.     ) ) ; end else, let
  542.      ) ; end cond 
  543.   )
  544.  
  545.   (quasi exp 0) ; need to unquote to level 0 to paint
  546. )
  547.  
  548. ;;                                      --- E O F ---
  549.