home *** CD-ROM | disk | FTP | other *** search
/ Club Amiga de Montreal - CAM / CAM_CD_1.iso / files / 213a.lha / Scheme / Tutorial / MACROS.S < prev    next >
Text File  |  1996-02-14  |  3KB  |  119 lines
  1. (define %compile compile)
  2.  
  3. (define (%expand-macros expr)
  4.   (if (pair? expr)
  5.     (if (symbol? (car expr))
  6.       (let ((expander (get (car expr) '%syntax)))
  7.         (if expander
  8.           (expander expr)
  9.           (let ((expander (get (car expr) '%macro)))
  10.             (if expander
  11.               (%expand-macros (expander expr))
  12.               (cons (car expr) (%expand-list (cdr expr)))))))
  13.       (%expand-list expr))
  14.     expr))
  15.  
  16. (define (%expand-list lyst)
  17.   (if (pair? lyst)
  18.     (cons (%expand-macros (car lyst)) (%expand-list (cdr lyst)))
  19.     lyst))
  20.  
  21. (define (compile expr #!optional env)
  22.   (if (default-object? env)
  23.     (%compile (%expand-macros expr))
  24.     (%compile (%expand-macros expr) env)))
  25.  
  26. (put 'macro '%macro
  27.   (lambda (form)
  28.     (list 'put
  29.           (list 'quote (cadr form))
  30.           (list 'quote '%macro)
  31.           (caddr form))))
  32.  
  33. (macro syntax
  34.   (lambda (form)
  35.     (list 'put
  36.           (list 'quote (cadr form))
  37.           (list 'quote '%syntax)
  38.           (caddr form))))
  39.  
  40. (syntax quote
  41.   (lambda (form) form))
  42.  
  43. (syntax lambda
  44.   (lambda (form)
  45.     (cons
  46.       'lambda
  47.       (cons
  48.         (cadr form)
  49.         (%expand-list (cddr form))))))
  50.  
  51. (syntax define
  52.   (lambda (form)
  53.     (cons
  54.       'define
  55.       (cons
  56.         (cadr form)
  57.         (%expand-list (cddr form))))))
  58.   
  59. (syntax set!
  60.   (lambda (form)
  61.     (cons
  62.       'set!
  63.       (cons
  64.         (cadr form)
  65.         (%expand-list (cddr form))))))
  66.  
  67. (define (%cond-expander lyst)
  68.   (cond
  69.       ((pair? lyst)
  70.        (cons
  71.          (if (pair? (car lyst))
  72.            (%expand-list (car lyst))
  73.            (car lyst))
  74.          (%cond-expander (cdr lyst))))
  75.       (else lyst)))
  76.  
  77. (syntax cond
  78.   (lambda (form)
  79.     (cons 'cond (%cond-expander (cdr form)))))
  80.  
  81. (define (%let-expander lyst)
  82.   (cond
  83.     ((pair? lyst)
  84.       (cons
  85.          (car lyst)
  86.          (%let-expander (cdr lyst))))
  87.       (else lyst)))
  88.  
  89. (syntax let
  90.   (lambda (form)
  91.     (cons
  92.       'let
  93.        (cons
  94.          (%let-expander (cadr form))
  95.          (%expand-list (cddr form))))))
  96.  
  97. (syntax let*
  98.   (lambda (form)
  99.     (cons
  100.       'let*
  101.        (cons
  102.          (%let-expander (cadr form))
  103.          (%expand-list (cddr form))))))
  104.  
  105. (syntax letrec
  106.   (lambda (form)
  107.     (cons
  108.       'letrec
  109.        (cons
  110.          (%let-expander (cadr form))
  111.          (%expand-list (cddr form))))))
  112.  
  113. (macro define-integrable
  114.   (lambda (form)
  115.     (cons 'define (cdr form))))
  116.  
  117. (macro declare
  118.   (lambda (form) #f))
  119.