home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 4 / Apprentice-Release4.iso / Languages / XLISP 3.0a1 / MACROS.LSP < prev    next >
Encoding:
Text File  |  1995-03-11  |  8.1 KB  |  281 lines  |  [TEXT/????]
  1. ; for XLisp 3.0
  2.  
  3. (define %compile compile)
  4.  
  5. (define (%expand-macros expr)
  6.   (if (pair? expr)
  7.     (if (symbol? (car expr))
  8.       (let ((expander (get (car expr) '%syntax)))
  9.         (if expander
  10.           (expander expr)
  11.           (let ((expander (get (car expr) '%macro)))
  12.             (if expander
  13.               (%expand-macros (expander expr))
  14.               (cons (car expr) (%expand-list (cdr expr)))))))
  15.       (%expand-list expr))
  16.     expr))
  17.  
  18. (define (%expand-list lyst)
  19.   (if (pair? lyst)
  20.     (cons (%expand-macros (car lyst)) (%expand-list (cdr lyst)))
  21.     lyst))
  22.  
  23. (define (compile expr #!optional env)
  24.   (if (default-object? env)
  25.     (%compile (%expand-macros expr))
  26.     (%compile (%expand-macros expr) env)))
  27.  
  28. (put 'macro '%macro
  29.   (lambda (form)
  30.     (list 'put
  31.           (list 'quote (cadr form))
  32.           (list 'quote '%macro)
  33.           (caddr form))))
  34.  
  35. (macro syntax
  36.   (lambda (form)
  37.     #f))
  38.  
  39. (macro compiler-syntax
  40.   (lambda (form)
  41.     (list 'put
  42.           (list 'quote (cadr form))
  43.           (list 'quote '%syntax)
  44.           (caddr form))))
  45.  
  46. (compiler-syntax quote
  47.   (lambda (form) form))
  48.       
  49. (compiler-syntax quasiquote
  50.   (lambda (x)
  51.     (qq-process (cadr x))))     
  52.     
  53. (define (parse-higher-order-function-definition lambda-list body)
  54.   (let loop ((lambda-list lambda-list) (body body))
  55.     (let ((var (car lambda-list))
  56.           (formals (cdr lambda-list)))
  57.       (if (symbol? var)
  58.         (values var `(named-lambda ,var ,formals ,@body))
  59.         (loop var `((lambda ,formals ,@body)))))))
  60.         
  61. (define (convert-internal-definitions body)
  62.   (let loop ((body body) (bindings '()))
  63.     (if (and body (pair? (car body)) (eq? (caar body) 'define))
  64.       (let* ((expr (car body))
  65.              (var (second expr)))
  66.         (if (pair? var)
  67.           (multiple-value-bind (var val)
  68.                                (parse-higher-order-function-definition var (cddr expr))
  69.             (loop (cdr body) (cons `(,var ,val) bindings)))
  70.           (let ((val (third expr)))
  71.             (loop (cdr body) (cons `(,var ,val) bindings)))))
  72.       (if bindings
  73.         `((letrec ,(reverse bindings) ,@body))
  74.         body))))
  75.  
  76. (compiler-syntax lambda
  77.   (lambda (form)
  78.     `(lambda ,(second form)
  79.        ,@(%expand-list (convert-internal-definitions (cddr form))))))
  80.  
  81. (compiler-syntax named-lambda
  82.   (lambda (form)
  83.     `(named-lambda ,(second form) ,(third form)
  84.        ,@(%expand-list (convert-internal-definitions (cdddr form))))))
  85.  
  86. (compiler-syntax define
  87.   (lambda (form)
  88.     (let ((var (second form)))
  89.       (if (pair? var)
  90.         (let ((body (%expand-list (convert-internal-definitions (cddr form)))))
  91.           (multiple-value-bind (var val)
  92.                                (parse-higher-order-function-definition var body)
  93.             `(define ,var ,val)))
  94.         (let ((val (%expand-macros (third form))))
  95.           (if (and (pair? val) (eq? (car val) 'lambda))
  96.             (let ((val `(named-lambda ,var ,@(cdr val))))
  97.               `(define ,var ,val))
  98.             `(define ,var ,val)))))))
  99.   
  100. (compiler-syntax multiple-value-bind
  101.   (lambda (form)
  102.     `(multiple-value-bind ,(second form)
  103.                           ,(%expand-macros (third form))
  104.        ,@(%expand-list (convert-internal-definitions (cdddr form))))))
  105.  
  106. (compiler-syntax set!
  107.   (lambda (form)
  108.     `(set!
  109.       ,(second form)
  110.       ,@(%expand-list (cddr form)))))
  111.  
  112. (define (%cond-expander lyst)
  113.   (cond
  114.       ((pair? lyst)
  115.        (cons
  116.          (if (pair? (car lyst))
  117.            (%expand-list (car lyst))
  118.            (car lyst))
  119.          (%cond-expander (cdr lyst))))
  120.       (else lyst)))
  121.  
  122. (compiler-syntax cond
  123.   (lambda (form)
  124.     `(cond ,@(%cond-expander (cdr form)))))
  125.  
  126. ; The following code for expanding let/let*/letrec was donated by:
  127. ;
  128. ; Harald Hanche-Olsen
  129. ; The University of Trondheim
  130. ; The Norwegian Institute of Technology
  131. ; Division of Mathematics
  132. ; N-7034 Trondheim NTH
  133. ; Norway
  134.  
  135. (define (%expand-let-assignment pair)
  136.   (if (pair? pair)
  137.     (cons
  138.       (car pair)
  139.       (%expand-macros (cdr pair)))
  140.     pair))
  141.  
  142. (define (%expand-let-form form)
  143.   (cons
  144.     (car form)
  145.     (cons
  146.       (let ((lyst (cadr form)))
  147.         (if (pair? lyst)
  148.           (map %expand-let-assignment lyst)
  149.           lyst))
  150.       (%expand-list (convert-internal-definitions (cddr form))))))
  151.  
  152. (compiler-syntax let %expand-let-form)
  153. (compiler-syntax let* %expand-let-form)
  154. (compiler-syntax letrec %expand-let-form)
  155.  
  156. (macro define-integrable
  157.   (lambda (form)
  158.     `(define ,@(cdr form))))
  159.  
  160. (macro declare
  161.   (lambda (form) #f))
  162.  
  163. (define (macro-expand x)
  164.   (let ((expander (get (car x) '%macro)))
  165.     (expander x)))
  166.     
  167. (define (subst new old tree)
  168.   (define (subst1 tree)
  169.     (cond ((pair? tree) (cons (subst1 (car tree))
  170.                               (subst1 (cdr tree))))
  171.           ((eqv? tree old) new)
  172.       (else tree)))
  173.   (subst1 tree))
  174.  
  175. (macro define-macro
  176.   (lambda (form)
  177.     (let ((name (caadr form))
  178.           (args (subst '&rest '&body (cdadr form)))
  179.           (body (cddr form)))
  180.       `(macro ,name (named-lambda ,name (form)
  181.                       (apply (lambda ,args ,@body) (cdr form)))))))
  182.  
  183. (define-macro (fluid-let bindings &body body)
  184.   (let ((vars (map (lambda (binding) (if (pair? binding) (car binding) binding)) bindings))
  185.         (inits (map (lambda (binding) (if (pair? binding) (cadr binding) binding)) bindings))
  186.         (init-vars (map (lambda (binding) (gensym)) bindings))
  187.         (save-vars (map (lambda (binding) (gensym)) bindings))
  188.         (make-set (lambda (v i) `(set! ,v ,i))))
  189.     `(let ,(append (map (lambda (sv v) (list sv v)) save-vars vars)
  190.                    (map (lambda (iv i) (list iv i)) init-vars inits))
  191.        (unwind-protect
  192.          (begin ,@(append (map make-set vars init-vars) body))
  193.          ,@(map make-set vars save-vars)))))
  194.                             
  195. (define-macro (when test &body body)
  196.   `(if ,test (begin ,@body)))
  197.  
  198. (define-macro (unless test &body body)
  199.   `(if (not ,test) (begin ,@body)))
  200.  
  201. (define-macro (case test &body cases)
  202.   (let* ((sym (gensym))
  203.          (clauses (map (lambda (x)
  204.                          (cond ((eq? (car x) 'else)
  205.                                 x)
  206.                    ((atom? (car x))
  207.                     `((eqv? ,sym ',(car x)) ,@(cdr x)))
  208.                    (else
  209.                                `((memv ,sym ',(car x)) ,@(cdr x)))))
  210.                       cases)) )
  211.     `(let ((,sym ,test))
  212.        (cond ,@clauses))))
  213.  
  214. (define-macro (multiple-value-list expr)
  215.   `(multiple-value-call list ,expr))
  216.     
  217. (define-macro (multiple-value-set! vars expr)
  218.   (let* ((tmps (map (lambda (x)
  219.                   (gensym))
  220.                 vars))
  221.      (set-forms (map (lambda (v tv)
  222.                            `(set! ,v ,tv))
  223.                          vars tmps)))
  224.     `(multiple-value-bind ,tmps
  225.               ,expr
  226.        ,@set-forms)))
  227.  
  228. ;;; Contributed by Matthew Halfant
  229.  
  230. (define-macro (push! ob lst)
  231.   `(begin 
  232.     (set! ,lst (cons ,ob ,lst))
  233.     ,lst))
  234.  
  235. ;;; (dotimes (i 10 [result]) (print i)) prints integers from 0 to 9
  236. ;;; This version doesn't support embedded RETURN.
  237. ;;; Contributed by Matthew Halfant
  238.  
  239. (define-macro (dotimes range &body body)
  240.   (let* ((incvar (car range))
  241.          (maxvar (cadr range))
  242.      (result (caddr range))
  243.          (loop (gensym)))
  244.     `(let ,loop ((,incvar 0))
  245.        (if (>= ,incvar ,maxvar)
  246.        ,result
  247.            (begin
  248.              ,@body
  249.              (,loop (+ ,incvar 1)))))))
  250.  
  251. (define-macro (do bindings test-result &body body)
  252.   (let ((loop (gensym))
  253.         (let-bindings nil)
  254.         (step-exprs nil)
  255.         (test (car test-result))
  256.         (result (cdr test-result)))
  257.     (let loop ((bindings bindings))
  258.       (if bindings
  259.         (let* ((binding (car bindings))
  260.                (var (first binding))
  261.                (init (second binding))
  262.                (step (if (cddr binding) (third binding) var)))
  263.           (push! (list var init) let-bindings)
  264.           (push! step step-exprs)
  265.           (loop (cdr bindings)))))
  266.     (set! let-bindings (reverse let-bindings))
  267.     (set! step-exprs (reverse step-exprs))
  268.     `(let ,loop ,let-bindings
  269.        (if ,test
  270.          (begin ,@result)
  271.          (begin ,@(append body (list (cons loop step-exprs))))))))
  272.                       
  273. (define-macro (time &body body)
  274.   (let ((time (gensym)))
  275.     `(let ((,time (get-time)))
  276.        (begin ,@body)
  277.        (set! ,time (- (get-time) ,time))
  278.        (format t "~%Elapsed time: ~A seconds" ,time)
  279.        ,time)))
  280.  
  281.