summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorMatthias Andreas Benkard <matthias@benkard.de>2008-07-31 19:58:00 +0200
committerMatthias Andreas Benkard <matthias@benkard.de>2008-07-31 19:58:00 +0200
commit5a3fb8cd4b7f99c7ac631c14fbb5282227bf8523 (patch)
tree83d3604a947e236bbdad5deea5f353cad412528b
parent01b311eaf70c95d68a0cbaa4117863f1771a9f3b (diff)
Reimplement SYS::QUASIQUOTE.
BLOCK and RETURN-FROM now seem to macroexpand properly.
-rw-r--r--util.lisp40
1 files changed, 32 insertions, 8 deletions
diff --git a/util.lisp b/util.lisp
index a30cd48..62d9e79 100644
--- a/util.lisp
+++ b/util.lisp
@@ -158,19 +158,43 @@
(%defun append lists
(%append lists))
-(%defmacro* sys::quasiquote (object)
+(%defun* %zerop (integer)
+ (send-by-name integer "isEqual:" 0))
+
+(%defun* %= (int1 int2)
+ (send-by-name int1 "isEqual:" int2))
+
+(%defun* %1- (integer)
+ (add integer -1))
+
+(%defun* %1+ (integer)
+ (add integer 1))
+
+(%defun* qq-expand (object level)
(if (not (consp object))
(list 'quote object)
- (cond ((eq 'sys::unquote (car object)) (car (cdr object)))
- ((eq 'sys::quasiquote (car object)) (list 'quote object))
+ (cond ((eq 'sys::unquote (car object))
+ (if (%= level 1)
+ (car (cdr object))
+ (list 'sys::unquote (qq-expand (car (cdr object)) (%1- level)))))
+ ((eq 'sys::quasiquote (car object))
+ (if (%zerop level)
+ (qq-expand (car (cdr object)) (%1+ level))
+ (list 'sys::quasiquote (qq-expand (car (cdr object)) (%1+ level)))))
((and (consp (car object))
(eq 'sys::unquote-splicing (car (car object))))
- (list 'append
- (car (cdr (car object)))
- (list 'sys::quasiquote (cdr object))))
+ (if (%= level 1)
+ (list 'append
+ (car (cdr (car object)))
+ (qq-expand (cdr object) level))
+ (list 'sys::unquote-splicing (qq-expand (car (cdr object))
+ (%1- level)))))
(t (list 'cons
- (list 'sys::quasiquote (car object))
- (list 'sys::quasiquote (cdr object)))))))
+ (qq-expand (car object) level)
+ (qq-expand (cdr object) level))))))
+
+(%defmacro sys::quasiquote form-and-env
+ (qq-expand (car form-and-env) 0))
(%defun* %member (item list)
(and list