home *** CD-ROM | disk | FTP | other *** search
/ Monster Media 1994 #1 / monster.zip / monster / PROG_PAS / APTERYX.ZIP / MACROS.LSP < prev    next >
Lisp/Scheme  |  1994-01-05  |  2KB  |  59 lines
  1. ; Copyright 1993 Apteryx Lisp Ltd
  2.  
  3. ; This is a file of macro definitions automatically
  4. ; loaded by apteryx.exe
  5. ; It should reside in the same directory as apteryx.exe
  6. ; Alter it or add to it at your own risk.
  7.  
  8. ; Make cons of let declaration and var update
  9. (defun _expand-do-dec (dec)
  10.   (cond 
  11.     ((symbolp dec) (cons (list dec nil) nil))
  12.     ((true-listp dec)
  13.       (case (length dec)
  14.         (1 (cons (list dec nil) nil))
  15.         (2 (cons dec nil))
  16.         (3 (cons 
  17.              (list (first dec) (second dec))
  18.              (list (first dec) (third dec)) ))
  19.         (t (error "Invalid do var declaration" dec)) ) )
  20.     (t (error "Invalid do var declaration" dec)) ) )
  21.  
  22. (defun _do-test (test-result)
  23.   (if (consp test-result)
  24.     (car test-result)
  25.     (error "Invalid do test and result expression") ) )
  26.  
  27. (defun _do-result (test-result)
  28.   (if (true-listp test-result)
  29.     (case (length test-result)
  30.       (1 nil)
  31.       (2 (second test-result))
  32.       (t ("Invalid do test and result" test-result)) )
  33.     ("Invalid do test and result" test-result) ) )
  34.  
  35. (defmacro do (vars test-result &rest stmts)
  36.   (let* ( (vars2 (mapcar #'_expand-do-dec vars))
  37.           (let-vars (mapcar #'car vars2))
  38.           (update-vars (mapcar #'cdr vars2))
  39.           (test (_do-test test-result))
  40.           (result (_do-result test-result)) )
  41.     `(let ,let-vars
  42.        (while (not ,test)
  43.          ,@stmts
  44.          (psetq ,@(apply #'append update-vars)) )
  45.        ,result) ) )
  46.  
  47. (defmacro do* (vars test-result &rest stmts)
  48.   (let* ( (vars2 (mapcar #'_expand-do-dec vars))
  49.           (let-vars (mapcar #'car vars2))
  50.           (update-vars (mapcar #'cdr vars2))
  51.           (test (_do-test test-result))
  52.           (result (_do-result test-result)) )
  53.     `(let* ,let-vars
  54.        (while (not ,test)
  55.          ,@stmts
  56.          (setq ,@(apply #'append update-vars)) )
  57.        ,result) ) )
  58.  
  59.