summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorMatthias Andreas Benkard <matthias@benkard.de>2008-07-30 21:20:07 +0200
committerMatthias Andreas Benkard <matthias@benkard.de>2008-07-30 21:20:07 +0200
commitc5cd5ea26f92e0e22631f858293d36507909d0f6 (patch)
tree1645576f63ab5907642101dd710db35b1190459b
parentbae90539e72d2d52d48ccf6f70560bf42af2e546 (diff)
Add prototypes of TAGBODY, GO, BLOCK, and RETURN-FROM.
-rw-r--r--control-flow.lisp84
-rw-r--r--list-functions-2.lisp8
2 files changed, 91 insertions, 1 deletions
diff --git a/control-flow.lisp b/control-flow.lisp
index 9fae748..2db9e4b 100644
--- a/control-flow.lisp
+++ b/control-flow.lisp
@@ -11,3 +11,87 @@
(defun complement (function)
(lambda (x) (not (funcall function x))))
+
+
+;; FIXME: Should be (EVAL-WHEN (:compile-toplevel) ...).
+(unless (boundp '+block-mapping-sym+)
+ ;; FIXME: Should be DEFCONSTANT.
+ (setq +block-mapping-sym+ (gensym)))
+
+(set +block-mapping-sym+ nil) ;FIXME: should be DEFLEX
+
+(defmacro block (block-name &body body)
+ (let ((catch-tag (gensym)))
+ `(compiler-let ((,+block-mapping-sym+ (acons ,block-name
+ ,catch-tag
+ ,+block-mapping-sym+)))
+ (catch ,catch-tag
+ ,@body))))
+
+(defmacro return-from (block-name &optional value)
+ ;; #, is like COMPILE-TIME-VALUE... in a way.
+ `(throw (compile-time-value (cdr (assoc ,+block-mapping-sym+)) t)
+ ,@(when value (list value))))
+
+
+;; FIXME: Should be (EVAL-WHEN (:compile-toplevel) ...).
+(unless (boundp '+go-tag-function-mapping-sym+)
+ ;; FIXME: Should be DEFCONSTANT.
+ (setq +go-tag-function-mapping-sym+ (gensym))
+ (setq +go-tag-catch-tag-mapping-sym+ (gensym)))
+
+(set +go-tag-function-mapping-sym+ nil) ;FIXME: should be DEFLEX
+(set +go-tag-catch-tag-mapping-sym+ nil) ;FIXME: should be DEFLEX
+
+;; FIXME: Implement TAGBODY and GO.
+(defmacro go (tag)
+ `(throw (compile-time-value (cdr (assoc ,+go-tag-catch-tag-mapping-sym+)) t)
+ #'#,(cdr (assoc ,+go-tag-function-mapping-sym+)) t))
+
+(defmacro tagbody (&body body)
+ (let* (labels-and-catch-tags
+ labels-and-functions
+ (catch-tag (gensym))
+ (block-name (gensym))
+ (return-value-sym (gensym))
+ (sections
+ (nreverse
+ (mapcon (let (current-label
+ accumulated-clauses
+ current-function)
+ (lambda (clause-and-rest)
+ (let ((clause (car clause-and-rest))
+ (rest (cdr clause-and-rest)))
+ (if (atom clause)
+ (progn
+ (when current-function
+ (push (cons current-label current-function)
+ labels-and-functions)
+ (push (cons current-label catch-tag)
+ labels-and-catch-tags))
+ (let ((old-function current-function))
+ (setq current-label clause
+ current-function (gensym))
+ `((,old-function ()
+ ,@(nreverse accumulated-clauses)
+ ,(if rest `#',current-function `nil)))))
+ (push clause accumulated-clauses)))))
+ body))))
+ `(compiler-let ((,+go-tag-catch-tag-mapping-sym+
+ (list* ,@(mapcar (lambda (x) (list 'quote x))
+ labels-and-catch-tags)
+ ,+go-tag-catch-tag-mapping-sym+))
+ (,+go-tag-function-mapping-sym+
+ (list* ,@(mapcar (lambda (x) (list 'quote x))
+ labels-and-functions)
+ ,+go-tag-function-mapping-sym+)))
+ (labels (,@(rest sections))
+ (block ,block-name
+ (let (,return-value-sym)
+ (loop-forever
+ (setq ,return-value-sym
+ (catch ,catch-tag
+ (if ,return-value-sym
+ (funcall ,return-value-sym)
+ (progn ,@(cddr (first sections))))
+ (return-from ,block-name nil))))))))))
diff --git a/list-functions-2.lisp b/list-functions-2.lisp
index c8d4ccd..1c99a4e 100644
--- a/list-functions-2.lisp
+++ b/list-functions-2.lisp
@@ -84,8 +84,14 @@
(cons (apply function (mapcar1 'car lists))
(apply 'mapcar (list* function (mapcar1 'cdr lists)))))))
+(defun maplist (function list &rest more-lists)
+ (let ((lists (list* list more-lists)))
+ (when (every1 'identity lists)
+ (cons (apply function lists)
+ (apply 'maplist (list* function (mapcar1 'cdr lists)))))))
+
(defun mapcan (function list &rest more-lists)
(%append (apply 'mapcar (list* function list more-lists))))
(defun mapcon (function list &rest more-lists)
- (apply (function mapcan) (list* function list more-lists)))
+ (%append (apply 'maplist (list* function list more-lists))))