summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--cond.lisp29
-rw-r--r--init.lisp1
-rw-r--r--util.lisp85
3 files changed, 85 insertions, 30 deletions
diff --git a/cond.lisp b/cond.lisp
deleted file mode 100644
index 7b3d1cc..0000000
--- a/cond.lisp
+++ /dev/null
@@ -1,29 +0,0 @@
-(%defun list* args
- (if (null (cdr args))
- (car args)
- (cons (car args)
- (apply 'list* (cdr args)))))
-
-(%defmacro let* args
- (let ((form (car args)))
- (let ((bindings (car (cdr form)))
- (body (cdr (cdr form))))
- (if (null bindings)
- (list* 'let nil body)
- (let ((first-binding (car bindings))
- (rest (cdr bindings)))
- (list 'let
- (list first-binding)
- (list* 'let* rest body)))))))
-
-(%defmacro cond args
- (let* ((form (car args))
- (clauses (cdr form))
- (clause (car clauses))
- (rest (cdr clauses)))
- (if (null clauses)
- nil
- (list 'if
- (car clause)
- (cons 'progn (cdr clause))
- (cons 'cond rest)))))
diff --git a/init.lisp b/init.lisp
index 4c4f5f0..cdd9997 100644
--- a/init.lisp
+++ b/init.lisp
@@ -1,5 +1,4 @@
(in-package :common-lisp)
(load "util.lisp")
-(load "cond.lisp")
(load "list-functions.lisp")
(in-package :common-lisp-user)
diff --git a/util.lisp b/util.lisp
index ed4c3a0..5fdff4c 100644
--- a/util.lisp
+++ b/util.lisp
@@ -2,3 +2,88 @@
(list '%fset
(list 'quote (car (cdr (car args))))
(cons '%lambda (cdr (cdr (car args))))))
+
+(%defun list* args
+ (if (null (cdr args))
+ (car args)
+ (cons (car args)
+ (apply 'list* (cdr args)))))
+
+(%defmacro let* args
+ (let ((form (car args)))
+ (let ((bindings (car (cdr form)))
+ (body (cdr (cdr form))))
+ (if (null bindings)
+ (list* 'let nil body)
+ (let ((first-binding (car bindings))
+ (rest (cdr bindings)))
+ (list 'let
+ (list first-binding)
+ (list* 'let* rest body)))))))
+
+(%defmacro cond args
+ (let* ((form (car args))
+ (clauses (cdr form))
+ (clause (car clauses))
+ (rest (cdr clauses)))
+ (if (null clauses)
+ nil
+ (list 'if
+ (car clause)
+ (cons 'progn (cdr clause))
+ (cons 'cond rest)))))
+
+(%defun not args
+ (if (null (car args)) t nil))
+
+(%defun make-%defmacro*-body args
+ (let ((lambda-list (car args))
+ (lambda-list-name (car (cdr args)))
+ (body (car (cdr (cdr args)))))
+ (cond ((null lambda-list) body)
+ ((not (listp lambda-list))
+ (list
+ (list* 'let
+ (list (list lambda-list lambda-list-name))
+ body)))
+ (t (let ((lambda-symbol (car lambda-list))
+ (rest-lambda-list (cdr lambda-list))
+ (rest-name (gensym)))
+ (list
+ (list* 'let
+ (list (list lambda-symbol
+ (list 'car lambda-list-name))
+ (list rest-name
+ (list 'cdr lambda-list-name)))
+ (make-%defmacro*-body (cdr lambda-list)
+ rest-name
+ body))))))))
+
+(%defmacro %defmacro* args
+ (let* ((form (car args))
+ (real-args (cdr form)))
+ (let ((name (car real-args))
+ (lambda-list (car (cdr real-args)))
+ (body (cdr (cdr real-args)))
+ (macro-lambda-list-name (gensym))
+ (lambda-list-name (gensym)))
+ (list '%defmacro
+ name
+ macro-lambda-list-name
+ (list* 'let
+ (list (list lambda-list-name
+ (list 'car macro-lambda-list-name)))
+ (make-%defmacro*-body lambda-list lambda-list-name body))))))
+
+(%defmacro* case (object . clauses)
+ (let ((this-clause (car clauses))
+ (rest (cdr clauses))
+ (object-sym (gensym)))
+ (if (null clauses)
+ nil
+ (list 'let
+ (list (list object-sym object))
+ (list 'if
+ (list 'eq object-sym (list 'quote (car this-clause)))
+ (cons 'progn (cdr this-clause))
+ (cons 'case object-sym rest))))))