1
;; define.jl -- Scheme define syntax
2
;; Copyright (C) 2000 John Harper <john@dcs.warwick.ac.uk>
4
;; $Id: define.jl,v 1.32 2001/08/08 06:00:20 jsh Exp $
6
;; This file is part of librep.
8
;; librep is free software; you can redistribute it and/or modify it
9
;; under the terms of the GNU General Public License as published by
10
;; the Free Software Foundation; either version 2, or (at your option)
13
;; librep is distributed in the hope that it will be useful, but
14
;; WITHOUT ANY WARRANTY; without even the implied warranty of
15
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
16
;; GNU General Public License for more details.
18
;; You should have received a copy of the GNU General Public License
19
;; along with librep; see the file COPYING. If not, write to
20
;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
22
(declare (unsafe-for-call/cc))
24
(declare (in-module rep.lang.interpreter))
26
(open-structures '(rep.lang.backquote))
30
;; This attempts to implement Scheme's elegant block-structured
31
;; function definitions. It will scan leading `define' forms from all
32
;; `define', `let', `let*', and `lambda' special forms (and from any
33
;; macros in terms of these special forms)
35
;; Note that the rep interpreter and compiler support scheme-like
36
;; lambda lists natively, so things like (define (foo . bar) ..) will
39
;; Note^2 that this doesn't work quite like Scheme define, in that the
40
;; outermost define always affects the global environment (unless
41
;; within a with-internal-definitions block) [the reason for this
42
;; ugliness is to avoid redefining lambda]
44
;; List of currently bound variables. Used to avoid expanding macros
45
;; that have been rebound locally
46
(%define define-bound-vars (make-fluid '()))
48
;; returns (SYM DEF [DOC])
49
(defun define-parse (args)
50
(if (consp (car args))
51
(define-parse `(,(caar args) (lambda ,(cdar args) ,@(cdr args))))
52
(list* (car args) (define-scan-form (cadr args))
53
(and (stringp (caddr args)) (list (caddr args))))))
55
(defun define-scan-internals (body)
58
(while (eq (caar body) 'define)
59
(setq defs (cons (define-parse (cdar body)) defs))
60
(setq body (cdr body)))
64
(list (car def) (cadr def))) (nreverse defs))
65
(define-scan-body body))
66
(let ((new-body (define-scan-body body)))
67
(if (null (cdr new-body))
69
(cons 'progn new-body))))))
71
(defun define-scan-body (body)
72
(let ((new (mapcar define-scan-form body)))
73
(if (equal new body) body new)))
75
(defun define-macroexpand-1 (form)
76
(if (memq (car form) (fluid define-bound-vars))
78
(macroexpand-1 form macro-environment)))
80
;; This needs to handle all special forms. It also needs to handle any
81
;; macros that the compiler wants to see without being expanded..
82
(defun define-scan-form (form)
85
(case (if (memq (car form) (fluid define-bound-vars)) '() (car form))
87
(if (and (eq (car form) 'let) (cadr form) (symbolp (cadr form)))
89
(define-scan-form (define-macroexpand-1 form))
90
(let loop ((rest (cadr form))
94
(list 'let (nreverse clauses)
95
(let-fluids ((define-bound-vars
96
(nconc vars (fluid define-bound-vars))))
97
(define-scan-internals (cddr form)))))
100
(cons (caar rest) vars)
101
(cons (cons (caar rest)
102
(define-scan-body (cdar rest))) clauses)))
104
(cons (car rest) vars)
105
(cons (car rest) clauses)))))))
108
(let-fluids ((define-bound-vars (fluid define-bound-vars)))
109
(let loop ((rest (cadr form))
112
(list 'let* (nreverse clauses)
113
(define-scan-internals (cddr form))))
115
(fluid-set define-bound-vars
116
(cons (caar rest) (fluid define-bound-vars)))
118
(cons (cons (caar rest)
119
(define-scan-body (cdar rest))) clauses)))
121
(fluid-set define-bound-vars
122
(cons (car rest) (fluid define-bound-vars)))
124
(cons (car rest) clauses)))))))
127
(let-fluids ((define-bound-vars
128
(nconc (mapcar (lambda (x) (or (car x) x)) (cadr form))
129
(fluid define-bound-vars))))
133
(cons (car x) (define-scan-body (cdr x)))
135
(define-scan-internals (cddr form)))))
141
(cons (car x) (define-scan-body (cdr x)))
143
(define-scan-internals (cddr form))))
146
(let loop ((rest (cdr form))
150
(cons (list (car rest)
151
(define-scan-form (cadr rest))) out))
152
(cons (car form) (apply nconc (nreverse out))))))
155
(cons 'cond (mapcar (lambda (clause)
156
(define-scan-body clause)) (cdr form))))
160
(define-scan-form (nth 1 form))
161
(mapcar (lambda (clause)
162
(cons (car clause) (define-scan-body (cdr clause))))
166
(let ((var (if (eq (cadr form) 'nil) nil (cadr form))))
167
(let-fluids ((define-bound-vars (cons var (fluid define-bound-vars))))
168
(list* 'condition-case (cadr form)
169
(define-scan-body (cddr form))))))
171
((catch unwind-protect progn)
172
(cons (car form) (define-scan-body (cdr form))))
174
((quote structure-ref) form)
177
(let ((vars (let loop ((rest (cadr form))
179
(cond ((null rest) vars)
180
((memq (or (caar rest) (car rest))
181
'(#!optional #!key #!rest &optional &rest))
182
(loop (cdr rest) vars))
183
(t (loop (cdr rest) (cons (or (caar rest)
184
(car rest)) vars))))))
185
(body (nthcdr 2 form))
187
;; skip doc strings and interactive decls..
188
(while (or (stringp (car body)) (eq (caar body) 'interactive))
189
(setq header (cons (car body) header))
190
(setq body (cdr body)))
191
`(lambda ,(cadr form)
193
,(let-fluids ((define-bound-vars
194
(nconc vars (fluid define-bound-vars))))
195
(define-scan-internals body)))))
198
(list* 'defvar (nth 1 form) (define-scan-form (nth 2 form))
201
((structure define-structure declare) form)
203
(t (let ((expansion (define-macroexpand-1 form)))
204
(if (eq expansion form)
205
(define-scan-body form)
206
(define-scan-form expansion)))))))
209
(defmacro define (#!rest args)
210
(let ((def (define-parse args)))
211
(let ((var (car def))
214
(if (eq (car value) 'lambda)
215
`(defun ,var ,(cadr value)
216
,@(and doc (list doc))
217
,@(let ((body (cddr value)))
218
(if (and (eq (car body) 'progn) (null (cdr body)))
221
(cons '%define def)))))
224
(defmacro define-macro (#!rest args)
225
(let ((def (define-parse args)))
226
(let ((var (car def))
229
(if (eq (car value) 'lambda)
230
`(defmacro ,var ,(cadr value)
231
,@(and doc (list doc))
232
,@(let ((body (cddr value)))
233
(if (and (eq (car body) 'progn) (null (cdr body)))
236
;; can only expand to defmacro forms (for the compiler's sake)
237
(error "Macros must be constant lambdas: %s" (car def))))))
240
(defmacro with-internal-definitions (#!rest body)
241
(define-scan-internals body))
added
removed
lisp/rep/lang/define.jl
