home *** CD-ROM | disk | FTP | other *** search
/ Power-Programmierung / CD1.mdf / lisp / interpre / apteryx / macros.lsp < prev    next >
Encoding:
Lisp/Scheme  |  1994-02-09  |  1.8 KB  |  56 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.     (cons 'progn (cdr test-result))
  30.     ("Invalid do test and result" test-result) ) )
  31.  
  32. (defmacro do (vars test-result &rest stmts)
  33.   (let* ( (vars2 (mapcar #'_expand-do-dec vars))
  34.           (let-vars (mapcar #'car vars2))
  35.           (update-vars (mapcar #'cdr vars2))
  36.           (test (_do-test test-result))
  37.           (result (_do-result test-result)) )
  38.     `(let ,let-vars
  39.        (while (not ,test)
  40.          ,@stmts
  41.          (psetq ,@(apply #'append update-vars)) )
  42.        ,result) ) )
  43.  
  44. (defmacro do* (vars test-result &rest stmts)
  45.   (let* ( (vars2 (mapcar #'_expand-do-dec vars))
  46.           (let-vars (mapcar #'car vars2))
  47.           (update-vars (mapcar #'cdr vars2))
  48.           (test (_do-test test-result))
  49.           (result (_do-result test-result)) )
  50.     `(let* ,let-vars
  51.        (while (not ,test)
  52.          ,@stmts
  53.          (setq ,@(apply #'append update-vars)) )
  54.        ,result) ) )
  55.  
  56.