source: trunk/j/src/org/armedbear/lisp/macros.lisp @ 4427

Last change on this file since 4427 was 4427, checked in by piso, 19 years ago

sys:%time => sys::%time

File size: 4.2 KB
Line 
1;;; macros.lisp
2;;;
3;;; Copyright (C) 2003 Peter Graves
4;;; $Id: macros.lisp,v 1.23 2003-10-17 14:05:55 piso Exp $
5;;;
6;;; This program is free software; you can redistribute it and/or
7;;; modify it under the terms of the GNU General Public License
8;;; as published by the Free Software Foundation; either version 2
9;;; of the License, or (at your option) any later version.
10;;;
11;;; This program is distributed in the hope that it will be useful,
12;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
13;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
14;;; GNU General Public License for more details.
15;;;
16;;; You should have received a copy of the GNU General Public License
17;;; along with this program; if not, write to the Free Software
18;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
19
20(in-package "COMMON-LISP")
21
22(defmacro return (&optional (value nil))
23  `(return-from nil ,value))
24
25(defmacro prog1 (first-form &rest forms)
26  (let ((result (gensym)))
27    `(let ((,result ,first-form))
28       ,@forms
29       ,result)))
30
31(defmacro prog2 (first-form second-form &rest forms)
32  `(prog1 (progn ,first-form ,second-form) ,@forms))
33
34(defmacro push (item place)
35  `(setf ,place (cons ,item ,place)))
36
37(defmacro pop (place)
38  `(prog1 (car ,place) (setf ,place (cdr ,place))))
39
40(defmacro pushnew (item place &rest keys)
41  `(setf ,place (adjoin ,item ,place ,@keys)))
42
43(defmacro psetq (&rest args)
44  (do ((l args (cddr l))
45       (forms nil)
46       (bindings nil))
47    ((endp l) (list* 'let* (reverse bindings) (reverse (cons nil forms))))
48    (let ((sym (gensym)))
49      (push (list sym (cadr l)) bindings)
50      (push (list 'setq (car l) sym) forms))))
51
52(defmacro time (form)
53  `(sys::%time #'(lambda () ,form)))
54
55(defmacro with-open-file (&rest args)
56  (let ((var (caar args))
57        (open-args (cdar args))
58        (forms (cdr args))
59        (abortp (gensym)))
60    `(let ((,var (open ,@open-args))
61     (,abortp t))
62       (unwind-protect
63        (multiple-value-prog1
64          (progn ,@forms)
65          (setq ,abortp nil))
66        (when ,var
67          (close ,var :abort ,abortp))))))
68
69(defmacro with-open-stream (&rest args)
70  (let ((var (caar args))
71        (stream (cadar args))
72        (forms (cdr args))
73        (abortp (gensym)))
74    `(let ((,var ,stream)
75     (,abortp t))
76       (unwind-protect
77        (multiple-value-prog1
78         (progn ,@forms)
79         (setq ,abortp nil))
80        (when ,var
81          (close ,var :abort ,abortp))))))
82
83
84;;; From CMUCL.
85
86(defun do-do-body (varlist endlist code bind step name block)
87  (let* ((inits ())
88   (steps ())
89   (L1 (gensym))
90   (L2 (gensym)))
91    ;; Check for illegal old-style do.
92    (when (or (not (listp varlist)) (atom endlist))
93      (error "Ill-formed ~S -- possibly illegal old style DO?" name))
94    ;; Parse the varlist to get inits and steps.
95    (dolist (v varlist)
96      (cond ((symbolp v) (push v inits))
97      ((listp v)
98       (unless (symbolp (first v))
99         (error "~S step variable is not a symbol: ~S" name (first v)))
100       (case (length v)
101         (1 (push (first v) inits))
102         (2 (push v inits))
103         (3 (push (list (first v) (second v)) inits)
104      (setq steps (list* (third v) (first v) steps)))
105         (t (error "~S is an illegal form for a ~S varlist." v name))))
106      (t (error "~S is an illegal form for a ~S varlist." v name))))
107    ;; And finally construct the new form.
108    `(block ,block
109            (,bind ,(nreverse inits)
110                   (tagbody
111                    (go ,L2)
112                    ,L1
113                    ,@code
114                    (,step ,@(nreverse steps))
115                    ,L2
116                    (unless ,(car endlist) (go ,L1))
117                    (return-from ,block (progn ,@(cdr endlist))))))))
118
119
120(defmacro do (varlist endlist &rest body)
121  (do-do-body varlist endlist body 'let 'psetq 'do nil))
122
123
124(defmacro do* (varlist endlist &rest body)
125  (do-do-body varlist endlist body 'let* 'setq 'do* nil))
126
127(defun ansi-loop (exps)
128  (require 'loop)
129  (fmakunbound 'ansi-loop)
130  `(loop ,@exps))
131
132(defmacro loop (&rest exps)
133  (dolist (exp exps)
134    (when (atom exp)
135      (return-from loop (ansi-loop exps))))
136  (let ((tag (gensym)))
137    `(block nil (tagbody ,tag ,@exps (go ,tag)))))
Note: See TracBrowser for help on using the repository browser.