+;; MISC ESSENTIAL PROCEDURES
+
+(define list
+ (lambda args args))
+
+(define map
+ (lambda (proc l)
+ (if (null? l)
+ '()
+ (cons (proc (car l)) (map proc (cdr l))))))
+
+(define join-lists
+ (lambda (l1 l2)
+ (if (null? l1)
+ l2
+ (cons (car l1) (join-lists (cdr l1) l2)))))
+
+; Append an arbitrary number of lists together
+(define append
+ (lambda lists
+ (if (null? lists)
+ ()
+ (if (null? (cdr lists))
+ (car lists)
+ (join-lists (car lists) (apply append (cdr lists)))))))
+
+
+;; DERIVED FORMS
+
+;; define
+
+(define-macro (define args . body)
+ (if (pair? args)
+ (list 'define (car args) (join-lists (list 'lambda (cdr args)) body))
+ 'no-match))
+
+;; not
+
+(define-macro (not x)
+ (list 'if x #f #t))
+
+;; let
+
+(define-macro (let args . body)
+ (join-lists
+ (list (join-lists (list 'lambda (map (lambda (x) (car x)) args)) body))
+ (map (lambda (x) (car (cdr x))) args)))
+
+;; quasiquote/unquote (one nesting level only)
+
+((lambda ()
+ (define (qqhelper l)
+ (if (null? l)
+ l
+ (let ((head (car l))
+ (tail (cdr l)))
+
+ (if (pair? head)
+ (if (eq? (car head) 'unquote)
+ (list 'cons (car (cdr head)) (qqhelper tail))
+ (if (eq? (car head) 'unquote-splicing)
+ (list 'join-lists (car (cdr head)) (qqhelper tail))
+ (list 'cons (list 'quasiquote head) (qqhelper tail))))
+ (if (symbol? head)
+ (list 'cons (list 'quote head) (qqhelper tail))
+ (list 'cons head (qqhelper tail)))))))
+
+ (define-macro (quasiquote arg)
+ (if (not (pair? arg))
+ (list 'quote arg)
+ (qqhelper arg)))))
+
+;; begin
+
+(define-macro (begin . sequence)
+ `((lambda () ,@sequence)))
+
+;; caddr etc.
+
+(define-macro (caar l) `(car (car ,l)))
+(define-macro (cadr l) `(car (cdr ,l)))
+(define-macro (cdar l) `(cdr (car ,l)))
+(define-macro (cddr l) `(cdr (cdr ,l)))
+(define-macro (caaar l) `(car (car (car ,l))))
+(define-macro (caadr l) `(car (car (cdr ,l))))
+(define-macro (cadar l) `(car (cdr (car ,l))))
+(define-macro (caddr l) `(car (cdr (cdr ,l))))
+(define-macro (cdaar l) `(cdr (car (car ,l))))
+(define-macro (cdadr l) `(cdr (car (cdr ,l))))
+(define-macro (cddar l) `(cdr (cdr (car ,l))))
+(define-macro (cdddr l) `(cdr (cdr (cdr ,l))))
+(define-macro (cadddr l) `(car (cdr (cdr (cdr ,l)))))
+
+;; let*
+
+(define-macro (let* args . body)
+ (if (null? args)
+ `(let () ,@body)
+ `(let (,(car args))
+ (let* ,(cdr args) ,@body))))
+
+;; while
+
+(define-macro (while condition . body)
+ (let ((loop (gensym)))
+ `(begin
+ (define (,loop)
+ (if ,condition
+ (begin ,@body (,loop))))
+ (,loop))))