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

Last change on this file since 11340 was 11340, checked in by ehuelsmann, 14 years ago

Use environment for macroexpansion and get-setf-expander
instead of the null environment (which will never hold bindings).

  • Property svn:eol-style set to native
  • Property svn:keywords set to Id
File size: 4.9 KB
Line 
1;;; macros.lisp
2;;;
3;;; Copyright (C) 2003-2007 Peter Graves
4;;; $Id: macros.lisp 11340 2008-10-11 16:15:53Z ehuelsmann $
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., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301, USA.
19
20(in-package "SYSTEM")
21
22(export 'defconst)
23
24(defmacro in-package (name)
25  `(%in-package ,(string name)))
26
27(defmacro when (test-form &rest body)
28  (if (cdr body)
29      `(if ,test-form (progn ,@body))
30      `(if ,test-form ,(car body))))
31
32(defmacro unless (test-form &rest body)
33  (if (cdr body)
34      `(if (not ,test-form) (progn ,@body))
35      `(if (not ,test-form) ,(car body))))
36
37(defmacro return (&optional result)
38  `(return-from nil ,result))
39
40(defmacro defconstant (name initial-value &optional docstring)
41  `(%defconstant ',name ,initial-value ,docstring))
42
43(defmacro defparameter (name initial-value &optional docstring)
44  `(%defparameter ',name ,initial-value ,docstring))
45
46(defmacro %car (x)
47  `(car (truly-the cons ,x)))
48
49(defmacro %cdr (x)
50  `(cdr (truly-the cons ,x)))
51
52(defmacro %cadr (x)
53  `(%car (%cdr ,x)))
54
55(defmacro %caddr (x)
56  `(%car (%cdr (%cdr ,x))))
57
58(defmacro prog1 (first-form &rest forms)
59  (let ((result (gensym)))
60    `(let ((,result ,first-form))
61       ,@forms
62       ,result)))
63
64(defmacro prog2 (first-form second-form &rest forms)
65  `(prog1 (progn ,first-form ,second-form) ,@forms))
66
67;; Adapted from SBCL.
68(defmacro push (&environment env item place)
69  (if (and (symbolp place)
70     (eq place (macroexpand place env)))
71      `(setq ,place (cons ,item ,place))
72      (multiple-value-bind (dummies vals newval setter getter)
73        (get-setf-expansion place env)
74        (let ((g (gensym)))
75          `(let* ((,g ,item)
76                  ,@(mapcar #'list dummies vals)
77                  (,(car newval) (cons ,g ,getter)))
78             ,setter)))))
79
80;; Adapted from SBCL.
81(defmacro pushnew (&environment env item place &rest keys)
82  (if (and (symbolp place)
83     (eq place (macroexpand place env)))
84      `(setq ,place (adjoin ,item ,place ,@keys))
85      (multiple-value-bind (dummies vals newval setter getter)
86        (get-setf-expansion place env)
87        (let ((g (gensym)))
88          `(let* ((,g ,item)
89                  ,@(mapcar #'list dummies vals)
90                  (,(car newval) (adjoin ,g ,getter ,@keys)))
91             ,setter)))))
92
93;; Adapted from SBCL.
94(defmacro pop (&environment env place)
95  (if (and (symbolp place)
96     (eq place (macroexpand place env)))
97      `(prog1 (car ,place)
98        (setq ,place (cdr ,place)))
99      (multiple-value-bind (dummies vals newval setter getter)
100        (get-setf-expansion place env)
101        (do* ((d dummies (cdr d))
102              (v vals (cdr v))
103              (let-list nil))
104             ((null d)
105              (push (list (car newval) getter) let-list)
106              `(let* ,(nreverse let-list)
107                 (prog1 (car ,(car newval))
108                        (setq ,(car newval) (cdr ,(car newval)))
109                        ,setter)))
110          (push (list (car d) (car v)) let-list)))))
111
112(defmacro psetq (&rest args)
113  (do ((l args (cddr l))
114       (forms nil)
115       (bindings nil))
116    ((endp l) (list* 'let* (reverse bindings) (reverse (cons nil forms))))
117    (let ((sym (gensym)))
118      (push (list sym (cadr l)) bindings)
119      (push (list 'setq (car l) sym) forms))))
120
121(defmacro time (form)
122  `(%time #'(lambda () ,form)))
123
124(defmacro with-open-stream (&rest args)
125  (let ((var (caar args))
126        (stream (cadar args))
127        (forms (cdr args))
128        (abortp (gensym)))
129    `(let ((,var ,stream)
130     (,abortp t))
131       (unwind-protect
132        (multiple-value-prog1
133         (progn ,@forms)
134         (setq ,abortp nil))
135        (when ,var
136          (close ,var :abort ,abortp))))))
137
138(defun ansi-loop (exps)
139  (let ((*warn-on-redefinition* nil))
140    (require 'loop))
141  (fmakunbound 'ansi-loop)
142  `(loop ,@exps))
143
144(defmacro loop (&rest exps)
145  (dolist (exp exps)
146    (when (atom exp)
147      (return-from loop (ansi-loop exps))))
148  (let ((tag (gensym)))
149    `(block nil (tagbody ,tag ,@exps (go ,tag)))))
150
151(defmacro defvar (var &optional (val nil valp) (doc nil docp))
152  `(progn
153     (%defvar ',var)
154     ,@(when valp
155         `((unless (boundp ',var)
156             (setq ,var ,val))))
157     ,@(when docp
158         `((%set-documentation ',var 'variable ',doc)))
159     ',var))
160
161(defmacro defconst (name value)
162  `(defconstant ,name
163     (if (boundp ',name)
164         (symbol-value ',name)
165         ,value)))
Note: See TracBrowser for help on using the repository browser.