home *** CD-ROM | disk | FTP | other *** search
/ The World of Computer Software / World_Of_Computer_Software-02-386-Vol-2of3.iso / c / cr-macro.zip / USUAL.SCM < prev    next >
Text File  |  1990-02-22  |  3KB  |  127 lines
  1. ; The usual macros
  2.  
  3. (define usual
  4.   (make-mutable-environment (make-transformer-environment)))
  5.  
  6. (define-special-operators! usual)
  7.  
  8. (set! test-environment usual)
  9.  
  10. (for-each (lambda (form)
  11.         (environment-define!
  12.          usual
  13.          (define-syntax-name form)
  14.          (process-syntax-binding (define-syntax-rhs form)
  15.                      usual)))
  16.       '(
  17.  
  18. (define-syntax define
  19.   (syntax-rules ()
  20.     ((define (name . rest) body +)
  21.      (%define name (lambda rest body +)))
  22.     ((define name rhs)
  23.      (%define name rhs))))
  24.  
  25. (define-syntax let
  26.   (syntax-rules ()
  27.     ((let ((name val) *) body +)
  28.      ((lambda (name *) body +) val *))
  29.     ((let tag ((name val) *) body +)
  30.      ((letrec ((tag (lambda (name *) body +)))
  31.     tag)
  32.       val *))))
  33.  
  34. (define-syntax let*
  35.   (syntax-rules ()
  36.     ((let* () body +)
  37.      (let () body +))
  38.     ((let* ((name1 val1) (name val) *) body +)
  39.      (let ((name1 val1)) (let* ((name val) *) body +)))))
  40.  
  41. (define-syntax and
  42.   (syntax-rules ()
  43.     ((and) #t)
  44.     ((and e) e)
  45.     ((and e1 e +) (if e1 (and e +) #f))))
  46.  
  47. (define-syntax or
  48.   (syntax-rules ()
  49.     ((or) #f)
  50.     ((or e) e)
  51.     ((or e1 e +) (let ((temp e1))
  52.            (if temp temp (or e +))))))
  53.  
  54. (define-syntax cond
  55.   (syntax-rules (else =>)
  56.     ((cond (else result +)) (begin result +))
  57.  
  58.     ((cond (test => result))
  59.      (let ((temp test))
  60.        (if temp (result temp))))
  61.  
  62.     ((cond (test)) test)
  63.  
  64.     ((cond (test result +)) (if test (begin result +)))
  65.  
  66.     ((cond (test => result) clause +)
  67.      (let ((temp test))
  68.        (if temp (result temp) (cond clause +))))
  69.  
  70.     ((cond (test) clause +)
  71.       (or test (cond clause +)))
  72.  
  73.     ((cond (test result +)
  74.        clause +)
  75.      (if test
  76.      (begin result +)
  77.      (cond clause +)))))
  78.  
  79. (define-syntax do
  80.   (syntax-rules ()
  81.     ((do ((name init step) *)
  82.      clause
  83.        body *)
  84.      (letrec ((loop (lambda (name *)
  85.               (cond clause
  86.                 (else
  87.                  (begin body *)
  88.                  (loop step *))))))
  89.        (loop init *)))))
  90.  
  91. (define-syntax delay
  92.   (syntax-rules ()
  93.     ((delay e) (make-promise (lambda () e)))))
  94.  
  95. (define-syntax case
  96.   (syntax-rules (else)
  97.     ((case e1 (else body +))
  98.      (begin e1 body +))
  99.     ((case e1 (z body +))
  100.      (if (memv e1 'z) (begin body +)))
  101.     ((case e1 (z body +) clause +)
  102.      (let ((temp e1))
  103.        (if (memv temp 'z)
  104.        (begin body +)
  105.        (case temp clause +))))))
  106.  
  107. ;; This one doesn't really work.
  108.  
  109. (define-syntax quasiquote
  110.   (syntax-rules (unquote unquote-splicing)
  111.     (`(,@exp . template) (append exp `template))
  112.     (`(template1 . template2) (cons `template1 `template2))
  113.     (`,exp exp)
  114.     (`thing 'thing)))
  115.  
  116. (define-syntax let*-syntax
  117.   (syntax-rules ()
  118.     ((let*-syntax () body)
  119.      (let-syntax () body))
  120.     ((let*-syntax ((name1 val1) (name val) *) body)
  121.      (let-syntax ((name1 val1)) (let*-syntax ((name val) *) body)))))
  122.  
  123.  
  124.         ))
  125.  
  126. ; (put 'syntax-rules 'scheme-indent-hook 1)
  127.