home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Monster Media 1994 #1
/
monster.zip
/
monster
/
PROG_GEN
/
APTERY.ZIP
/
MACROS.LSP
< prev
next >
Wrap
Lisp/Scheme
|
1994-01-05
|
2KB
|
59 lines
; Copyright 1993 Apteryx Lisp Ltd
; This is a file of macro definitions automatically
; loaded by apteryx.exe
; It should reside in the same directory as apteryx.exe
; Alter it or add to it at your own risk.
; Make cons of let declaration and var update
(defun _expand-do-dec (dec)
(cond
((symbolp dec) (cons (list dec nil) nil))
((true-listp dec)
(case (length dec)
(1 (cons (list dec nil) nil))
(2 (cons dec nil))
(3 (cons
(list (first dec) (second dec))
(list (first dec) (third dec)) ))
(t (error "Invalid do var declaration" dec)) ) )
(t (error "Invalid do var declaration" dec)) ) )
(defun _do-test (test-result)
(if (consp test-result)
(car test-result)
(error "Invalid do test and result expression") ) )
(defun _do-result (test-result)
(if (true-listp test-result)
(case (length test-result)
(1 nil)
(2 (second test-result))
(t ("Invalid do test and result" test-result)) )
("Invalid do test and result" test-result) ) )
(defmacro do (vars test-result &rest stmts)
(let* ( (vars2 (mapcar #'_expand-do-dec vars))
(let-vars (mapcar #'car vars2))
(update-vars (mapcar #'cdr vars2))
(test (_do-test test-result))
(result (_do-result test-result)) )
`(let ,let-vars
(while (not ,test)
,@stmts
(psetq ,@(apply #'append update-vars)) )
,result) ) )
(defmacro do* (vars test-result &rest stmts)
(let* ( (vars2 (mapcar #'_expand-do-dec vars))
(let-vars (mapcar #'car vars2))
(update-vars (mapcar #'cdr vars2))
(test (_do-test test-result))
(result (_do-result test-result)) )
`(let* ,let-vars
(while (not ,test)
,@stmts
(setq ,@(apply #'append update-vars)) )
,result) ) )