src/scheme-library-2-derived-forms.scm

   1 ;; DERIVED FORMS
   2
   3 ;; define
   4
   5 (define-macro (define args . body)
   6               (if (pair? args)
   7                 (list 'define (car args) (join-lists (list 'lambda (cdr args)) body))
   8                 'no-match))
   9
  10 ;; not
  11
  12 (define-macro (not x)
  13               (list 'if x #f #t))
  14
  15 ;; let
  16
  17 (define-macro (let args . body)
  18               (join-lists
  19                 (list (join-lists (list 'lambda (map (lambda (x) (car x)) args)) body))
  20                 (map (lambda (x) (car (cdr x))) args)))
  21
  22 ;; quasiquote/unquote (one nesting level only)
  23
  24 ((lambda ()
  25    (define (qqhelper l)
  26      (if (null? l)
  27        l
  28        (let ((head (car l))
  29              (tail (cdr l)))
  30
  31          (if (pair? head)
  32              (if (eq? (car head) 'unquote)
  33                  (list 'cons (car (cdr head)) (qqhelper tail))
  34                  (if (eq? (car head) 'unquote-splicing)
  35                      (list 'join-lists (car (cdr head)) (qqhelper tail))
  36                      (list 'cons (list 'quasiquote head) (qqhelper tail))))
  37              (if (symbol? head)
  38                  (list 'cons (list 'quote head) (qqhelper tail))
  39                  (list 'cons head (qqhelper tail)))))))
  40
  41    (define-macro (quasiquote arg)
  42                  (if (not (pair? arg))
  43                    (list 'quote arg)
  44                    (qqhelper arg)))))
  45
  46 ;; begin
  47
  48 (define-macro (begin . sequence)
  49               `((lambda () ,@sequence)))
  50
  51 ;; caddr etc.
  52
  53 (define-macro (caar l) `(car (car ,l)))
  54 (define-macro (cadr l) `(car (cdr ,l)))
  55 (define-macro (cdar l) `(cdr (car ,l)))
  56 (define-macro (cddr l) `(cdr (cdr ,l)))
  57 (define-macro (caaar l) `(car (car (car ,l))))
  58 (define-macro (caadr l) `(car (car (cdr ,l))))
  59 (define-macro (cadar l) `(car (cdr (car ,l))))
  60 (define-macro (caddr l) `(car (cdr (cdr ,l))))
  61 (define-macro (cdaar l) `(cdr (car (car ,l))))
  62 (define-macro (cdadr l) `(cdr (car (cdr ,l))))
  63 (define-macro (cddar l) `(cdr (cdr (car ,l))))
  64 (define-macro (cdddr l) `(cdr (cdr (cdr ,l))))
  65 (define-macro (cadddr l) `(car (cdr (cdr (cdr ,l)))))
  66
  67 ;; let*
  68
  69 (define-macro (let* args . body)
  70               (if (null? args)
  71                 `(let () ,@body)
  72                 `(let (,(car args))
  73                    (let* ,(cdr args) ,@body))))
  74
  75 ;; while
  76
  77 (define-macro (while condition . body)
  78               (let ((loop (gensym)))
  79                 `(begin
  80                    (define (,loop)
  81                      (if ,condition
  82                        (begin ,@body (,loop))))
  83                    (,loop))))
  84
  85 ;; cond
  86
  87 ((lambda ()
  88    (define (cond-predicate clause) (car clause))
  89    (define (cond-actions clause) (cdr clause))
  90    (define (cond-else-clause? clause)
  91      (eq? (cond-predicate clause) 'else))
  92
  93    (define (expand-clauses clauses)
  94      (if (null? clauses)
  95        (none)
  96        (let ((first (car clauses))
  97              (rest (cdr clauses)))
  98          (if (cond-else-clause? first)
  99            (if (null? rest)
 100              `(begin ,@(cond-actions first))
 101              (error "else clause isn't last in cond expression."))
 102            `(if ,(cond-predicate first)
 103               (begin ,@(cond-actions first))
 104               ,(expand-clauses rest))))))
 105
 106    (define-macro (cond . clauses)
 107                  (if (null? clauses)
 108                    (error "cond requires at least one clause.")
 109                    (expand-clauses clauses)))))
 110
 111 ;; and
 112
 113 ((lambda ()
 114    (define (expand-and-expressions expressions)
 115      (let ((first (car expressions))
 116            (rest (cdr expressions)))
 117        (if (null? rest)
 118          first
 119          `(if ,first
 120             ,(expand-and-expressions rest)
 121             #f))))
 122
 123    (define-macro (and . expressions)
 124                  (if (null? expressions)
 125                    #t
 126                    (expand-and-expressions expressions)))))
 127
 128 ;; or
 129
 130 ((lambda ()
 131    (define (expand-or-expressions expressions)
 132      (let ((first (car expressions))
 133            (rest (cdr expressions)))
 134        (if (null? rest)
 135            first
 136            `(if ,first
 137                 #t
 138                 ,(expand-or-expressions rest)))))
 139
 140    (define-macro (or . expressions)
 141      (if (null? expressions)
 142          #f
 143          (expand-or-expressions expressions)))))
 144