mirror of
https://gitlab.com/embeddable-common-lisp/ecl.git
synced 2025-12-06 02:40:26 -08:00
Fix the compiler so that when it finds LOCALLY, MACROLET or SYMBOL-MACROLET
at the top level, it processes their bodies as top level forms as well. For instance, (LOCALLY (EVAL-WHEN (:COMPILE-TOPLEVEL) (PRINT "HELLO"))), now works.
This commit is contained in:
jjgarcia
parent
b4a5edcce4
commit
8563a1fc1c
14 changed files with 289 additions and 215 deletions
|
|
@ -683,6 +683,10 @@ ECLS 0.3
|
|||
* Remove variable si::*system-directory* and use logical hostname
|
||||
"SYS:" instead.
|
||||
|
||||
* Fix the compiler so that when it finds LOCALLY, MACROLET or
|
||||
SYMBOL-MACROLET at the top level, it processes their bodies as top
|
||||
level forms as well.
|
||||
|
||||
|
||||
TODO:
|
||||
=====
|
||||
|
|
|
|||
|
|
@ -1029,7 +1029,7 @@ c_let_leta(int op, cl_object args) {
|
|||
var = pop(&aux);
|
||||
value = pop_maybe_nil(&aux);
|
||||
if (!Null(aux))
|
||||
FEprogram_error("LET: Ill formed declaration ~S.",0);
|
||||
FEprogram_error("LET: Ill formed declaration.",0);
|
||||
}
|
||||
if (!SYMBOLP(var))
|
||||
FEillegal_variable_name(var);
|
||||
|
|
|
|||
|
|
@ -14,7 +14,7 @@
|
|||
(defun get-method-function (method) (nth 4 method))
|
||||
|
||||
;;; They will be redefined later:
|
||||
(proclaim '(notinline get-method-qualifiers get-method-function))
|
||||
(declaim (notinline get-method-qualifiers get-method-function))
|
||||
|
||||
|
||||
;;;
|
||||
|
|
|
|||
|
|
@ -19,7 +19,7 @@
|
|||
|
||||
;(proclaim '(DECLARATION VARIABLE-REBINDING))
|
||||
;;; Make this stable:
|
||||
(declaim '(DECLARATION VARIABLE-REBINDING))
|
||||
(declaim (DECLARATION VARIABLE-REBINDING))
|
||||
|
||||
(defvar *keyword-package* (find-package 'KEYWORD))
|
||||
|
||||
|
|
@ -77,8 +77,8 @@
|
|||
|
||||
;;; ECL implementation:
|
||||
|
||||
(proclaim '(function si:instance-ref (t fixnum) t))
|
||||
(proclaim '(function si:instance-set (t fixnum t) t))
|
||||
(declaim (function si:instance-ref (t fixnum) t))
|
||||
(declaim (function si:instance-set (t fixnum t) t))
|
||||
|
||||
(defmacro unbound () '(sys:nani 0))
|
||||
|
||||
|
|
|
|||
|
|
@ -253,10 +253,10 @@
|
|||
|
||||
;; Call to a function defined in the same file.
|
||||
((setq fd (assoc fname *global-funs*))
|
||||
(let ((cfun (cdr fd)))
|
||||
(let ((cfun (second fd)))
|
||||
(unwind-exit (call-loc fname
|
||||
(if (numberp cfun)
|
||||
(format nil "L~d" (cdr fd))
|
||||
(format nil "L~d" cfun)
|
||||
cfun)
|
||||
locs narg))))
|
||||
|
||||
|
|
|
|||
|
|
@ -356,7 +356,8 @@
|
|||
; with fixed number of arguments.
|
||||
; watch out for multiple values.
|
||||
|
||||
(defvar *global-funs* nil) ; holds { ( global-fun-name cfun ) }*
|
||||
(defvar *global-vars* nil)
|
||||
(defvar *global-funs* nil) ; holds { ( global-fun-name cfun ... ) }*
|
||||
(defvar *linking-calls* nil) ; holds { ( global-fun-name vv ) }*
|
||||
(defvar *local-funs* nil) ; holds { ( closurep fun funob ) }*
|
||||
(defvar *top-level-forms* nil) ; holds { top-level-form }*
|
||||
|
|
|
|||
|
|
@ -388,74 +388,80 @@
|
|||
(values body ss ts is others doc)
|
||||
)
|
||||
|
||||
(defun c1decl-body (decls body &aux (dl nil))
|
||||
(defun c1add-declarations (decls &aux (dl nil))
|
||||
(dolist (decl decls dl)
|
||||
(case (car decl)
|
||||
(OPTIMIZE
|
||||
(push decl dl)
|
||||
(dolist (x (cdr decl))
|
||||
(when (symbolp x) (setq x (list x 3)))
|
||||
(if (or (not (consp x))
|
||||
(not (consp (cdr x)))
|
||||
(not (numberp (second x)))
|
||||
(not (<= 0 (second x) 3)))
|
||||
(warn "The OPTIMIZE proclamation ~s is illegal." x)
|
||||
(case (car x)
|
||||
(SAFETY
|
||||
(let ((level (second x)))
|
||||
(declare (fixnum level))
|
||||
(setq *compiler-check-args* (>= level 1)
|
||||
*safe-compile* (>= level 2)
|
||||
*compiler-push-events* (>= level 3))))
|
||||
(SPACE (setq *space* (second x)))
|
||||
((SPEED COMPILATION-SPEED))
|
||||
(t (warn "The OPTIMIZE quality ~s is unknown."
|
||||
(car x)))))))
|
||||
(FTYPE
|
||||
(if (or (endp (cdr decl))
|
||||
(not (consp (second decl)))
|
||||
(not (eq (caadr decl) 'FUNCTION))
|
||||
(endp (cdadr decl)))
|
||||
(warn "The function declaration ~s is illegal." decl)
|
||||
(dolist (fname (cddr decl))
|
||||
(add-function-declaration
|
||||
fname (cadadr decl) (cddadr decl)))))
|
||||
(FUNCTION
|
||||
(if (or (endp (cdr decl))
|
||||
(endp (cddr decl))
|
||||
(not (symbolp (second decl))))
|
||||
(warn "The function declaration ~s is illegal." decl)
|
||||
(add-function-declaration
|
||||
(second decl) (caddr decl) (cdddr decl))))
|
||||
(INLINE
|
||||
(push decl dl)
|
||||
(dolist (fun (cdr decl))
|
||||
(if (symbolp fun)
|
||||
(setq *notinline* (remove fun *notinline*))
|
||||
(warn "The function name ~s is not a symbol." fun))))
|
||||
(NOTINLINE
|
||||
(push decl dl)
|
||||
(dolist (fun (cdr decl))
|
||||
(if (symbolp fun)
|
||||
(push fun *notinline*)
|
||||
(warn "The function name ~s is not a symbol." fun))))
|
||||
(DECLARATION
|
||||
(dolist (x (cdr decl))
|
||||
(if (symbolp x)
|
||||
(pushnew x *alien-declarations*)
|
||||
(warn "The declaration specifier ~s is not a symbol."
|
||||
x))))
|
||||
(otherwise
|
||||
(unless (member (car decl) *alien-declarations*)
|
||||
(warn "The declaration specifier ~s is unknown."
|
||||
(car decl)))))))
|
||||
|
||||
(defun c1decl-body (decls body)
|
||||
(if (null decls)
|
||||
(c1progn body)
|
||||
(let ((*function-declarations* *function-declarations*)
|
||||
(*alien-declarations* *alien-declarations*)
|
||||
(*notinline* *notinline*)
|
||||
(*space* *space*))
|
||||
(dolist (decl decls dl)
|
||||
(case (car decl)
|
||||
(OPTIMIZE
|
||||
(dolist (x (cdr decl))
|
||||
(when (symbolp x) (setq x (list x 3)))
|
||||
(if (or (not (consp x))
|
||||
(not (consp (cdr x)))
|
||||
(not (numberp (second x)))
|
||||
(not (<= 0 (second x) 3)))
|
||||
(warn "The OPTIMIZE proclamation ~s is illegal." x)
|
||||
(case (car x)
|
||||
(SAFETY (push (list 'SAFETY (second x)) dl))
|
||||
(SPACE (setq *space* (second x))
|
||||
(push (list 'SPACE (second x)) dl))
|
||||
((SPEED COMPILATION-SPEED))
|
||||
(t (warn "The OPTIMIZE quality ~s is unknown."
|
||||
(car x)))))))
|
||||
(FTYPE
|
||||
(if (or (endp (cdr decl))
|
||||
(not (consp (second decl)))
|
||||
(not (eq (caadr decl) 'FUNCTION))
|
||||
(endp (cdadr decl)))
|
||||
(warn "The function declaration ~s is illegal." decl)
|
||||
(dolist (fname (cddr decl))
|
||||
(add-function-declaration
|
||||
fname (cadadr decl) (cddadr decl)))))
|
||||
(FUNCTION
|
||||
(if (or (endp (cdr decl))
|
||||
(endp (cddr decl))
|
||||
(not (symbolp (second decl))))
|
||||
(warn "The function declaration ~s is illegal." decl)
|
||||
(add-function-declaration
|
||||
(second decl) (caddr decl) (cdddr decl))))
|
||||
(INLINE
|
||||
(dolist (fun (cdr decl))
|
||||
(if (symbolp fun)
|
||||
(progn (push (list 'INLINE fun) dl)
|
||||
(setq *notinline* (remove fun *notinline*)))
|
||||
(warn "The function name ~s is not a symbol." fun))))
|
||||
(NOTINLINE
|
||||
(dolist (fun (cdr decl))
|
||||
(if (symbolp fun)
|
||||
(progn (push (list 'NOTINLINE fun) dl)
|
||||
(push fun *notinline*))
|
||||
(warn "The function name ~s is not a symbol." fun))))
|
||||
(DECLARATION
|
||||
(dolist (x (cdr decl))
|
||||
(if (symbolp x)
|
||||
(pushnew x *alien-declarations*)
|
||||
(warn "The declaration specifier ~s is not a symbol."
|
||||
x))))
|
||||
(otherwise
|
||||
(unless (member (car decl) *alien-declarations*)
|
||||
(warn "The declaration specifier ~s is unknown."
|
||||
(car decl))))
|
||||
))
|
||||
(setq body (c1progn body))
|
||||
(list 'DECL-BODY (second body) dl body)
|
||||
)
|
||||
)
|
||||
)
|
||||
(let* ((*function-declarations* *function-declarations*)
|
||||
(*alien-declarations* *alien-declarations*)
|
||||
(*notinline* *notinline*)
|
||||
(*space* *space*)
|
||||
(*compiler-check-args* *compiler-check-args*)
|
||||
(*compiler-push-events* *compiler-push-events*)
|
||||
(dl (c1add-declarations decls)))
|
||||
(setq body (c1progn body))
|
||||
(list 'DECL-BODY (second body) dl body))))
|
||||
|
||||
(setf (get 'decl-body 'c2) 'c2decl-body)
|
||||
|
||||
|
|
@ -465,21 +471,8 @@
|
|||
(*compiler-push-events* *compiler-push-events*)
|
||||
(*notinline* *notinline*)
|
||||
(*space* *space*))
|
||||
(dolist (decl decls)
|
||||
(case (car decl)
|
||||
(SAFETY
|
||||
(let ((level (second decl)))
|
||||
(declare (fixnum level))
|
||||
(setq *compiler-check-args* (>= level 1)
|
||||
*safe-compile* (>= level 2)
|
||||
*compiler-push-events* (>= level 3))))
|
||||
(SPACE (setq *space* (second decl)))
|
||||
(NOTINLINE (push (second decl) *notinline*))
|
||||
(INLINE
|
||||
(setq *notinline* (remove (second decl) *notinline*)))
|
||||
(otherwise (baboon))))
|
||||
(c2expr body))
|
||||
)
|
||||
(c1add-declarations decls)
|
||||
(c2expr body)))
|
||||
|
||||
(defun check-vdecl (vnames ts is)
|
||||
(dolist (x ts)
|
||||
|
|
|
|||
|
|
@ -226,7 +226,14 @@
|
|||
(list 'LOCALS info local-funs body T) ; T means labels
|
||||
body))
|
||||
|
||||
(defun c1macrolet (args &aux (*funs* *funs*) (*vars* *vars*))
|
||||
(defun c1locally (args)
|
||||
(multiple-value-bind (body ss ts is other-decl)
|
||||
(c1body args t)
|
||||
(c1add-globals ss)
|
||||
(check-vdecl nil ts is)
|
||||
(c1decl-body other-decl body)))
|
||||
|
||||
(defun c1macrolet (args &aux (*funs* *funs*))
|
||||
(when (endp args) (too-few-args 'macrolet 1 0))
|
||||
(dolist (def (car args))
|
||||
(cmpck (or (endp def) (not (symbolp (car def))) (endp (cdr def)))
|
||||
|
|
@ -236,23 +243,15 @@
|
|||
(si::make-lambda (car def)
|
||||
(cdr (sys::expand-defmacro (car def) (second def) (cddr def)))))
|
||||
*funs*))
|
||||
(multiple-value-bind (body ss ts is other-decl)
|
||||
(c1body (cdr args) t)
|
||||
(c1add-globals ss)
|
||||
(check-vdecl nil ts is)
|
||||
(c1decl-body other-decl body)))
|
||||
(c1locally (cdr args)))
|
||||
|
||||
(defun c1symbol-macrolet (args &aux (*funs* *funs*) (*vars* *vars*))
|
||||
(defun c1symbol-macrolet (args &aux (*vars* *vars*))
|
||||
(when (endp args) (too-few-args 'symbol-macrolet 1 0))
|
||||
(dolist (def (car args))
|
||||
(cmpck (or (endp def) (not (symbolp (car def))) (endp (cdr def)))
|
||||
"The symbol-macro definition ~s is illegal." def)
|
||||
(push def *vars*))
|
||||
(multiple-value-bind (body ss ts is other-decl)
|
||||
(c1body (cdr args) t)
|
||||
(c1add-globals ss)
|
||||
(check-vdecl nil ts is)
|
||||
(c1decl-body other-decl body)))
|
||||
(c1locally (cdr args)))
|
||||
|
||||
(defun local-closure (fname &aux (ccb nil) (clb nil))
|
||||
(dolist (fun *funs*)
|
||||
|
|
|
|||
|
|
@ -388,8 +388,8 @@
|
|||
'SHIFT>>)))))
|
||||
(c1expr (cons fun args)))))
|
||||
|
||||
(defun shift>> (a b) (ash a b))
|
||||
(defun shift<< (a b) (ash a b))
|
||||
(setf (symbol-function 'shift<<) #'ash)
|
||||
(setf (symbol-function 'shift>>) #'ash)
|
||||
(setf (get 'SHIFT>> 'Lfun) "Lash")
|
||||
(setf (get 'SHIFT<< 'Lfun) "Lash")
|
||||
|
||||
|
|
|
|||
|
|
@ -12,7 +12,16 @@
|
|||
|
||||
(in-package "COMPILER")
|
||||
|
||||
(defun t1expr (form &aux (*current-form* form) (*first-error* t)
|
||||
(defun t1expr (form)
|
||||
(let ((*vars* nil)
|
||||
(*funs* nil)
|
||||
(*blocks* nil)
|
||||
(*tags* nil)
|
||||
(*sharp-commas* nil)
|
||||
(*special-binding* nil))
|
||||
(push (t1expr* form) *top-level-forms*)))
|
||||
|
||||
(defun t1expr* (form &aux (*current-form* form) (*first-error* t)
|
||||
*funarg-vars*
|
||||
(*setjmps* 0))
|
||||
(catch *cmperr-tag*
|
||||
|
|
@ -26,14 +35,17 @@
|
|||
(when *non-package-operation*
|
||||
(cmpwarn "The package operation ~s was in a bad place."
|
||||
form))
|
||||
(cmp-eval form)
|
||||
(cmp-eval form)
|
||||
(wt-data-package-operation form))
|
||||
((setq fd (get fun 'T1))
|
||||
(when *compile-print* (print-current-form))
|
||||
(funcall fd args))
|
||||
((get fun 'C1) (t1ordinary form))
|
||||
((setq fd (macro-function fun))
|
||||
(t1expr (cmp-expand-macro fd fun (cdr form))))
|
||||
(t1expr* (cmp-expand-macro fd fun (cdr form))))
|
||||
((and (setq fd (assoc fun *funs*))
|
||||
(eq (second fd) 'MACRO))
|
||||
(t1expr* (cmp-expand-macro (third fd) fun (cdr form))))
|
||||
(t (t1ordinary form))
|
||||
))
|
||||
;; #+cltl2
|
||||
|
|
@ -41,8 +53,47 @@
|
|||
(t1ordinary form))
|
||||
((consp fun) (t1ordinary form))
|
||||
(t (cmperr "~s is illegal function." fun)))
|
||||
)))
|
||||
)
|
||||
))))
|
||||
|
||||
(defun t2expr (form)
|
||||
;(pprint (cons 'T2 form))
|
||||
(when form
|
||||
(let ((def (get (car form) 'T2)))
|
||||
(when def (apply def (cdr form))))))
|
||||
|
||||
(defvar *emitted-local-funs* nil)
|
||||
|
||||
(defun emit-local-funs ()
|
||||
;; Local functions and closure functions
|
||||
(do ()
|
||||
;; repeat until t3local-fun generates no more
|
||||
((eq *emitted-local-funs* *local-funs*))
|
||||
;; scan *local-funs* backwards
|
||||
(do ((lfs *local-funs* (cdr lfs)))
|
||||
((eq (cdr lfs) *emitted-local-funs*)
|
||||
(setq *emitted-local-funs* lfs)
|
||||
(when *compile-print*
|
||||
(print-emitting (fun-name (cadar lfs))))
|
||||
(locally (declare (notinline t3local-fun))
|
||||
;; so disassemble can redefine it
|
||||
(apply 't3local-fun (car lfs)))))))
|
||||
|
||||
(defun t3expr (form)
|
||||
;(pprint (cons 'T3 form))
|
||||
(when form
|
||||
(emit-local-funs)
|
||||
(setq *funarg-vars* nil)
|
||||
(let ((def (get (car form) 'T3)))
|
||||
(when def
|
||||
;; new local functions get pushed into *local-funs*
|
||||
(when (and *compile-print*
|
||||
(member (car form)
|
||||
'(DEFUN DEFMACRO DEFCBODY) ; DEFENTRY DEFUNC
|
||||
:test #'eq))
|
||||
(print-emitting (second form)))
|
||||
(apply def (cdr form))))
|
||||
(emit-local-funs)
|
||||
(setq *funarg-vars* nil)))
|
||||
|
||||
(defun ctop-write (name h-namestring data-namestring
|
||||
&optional system-p
|
||||
|
|
@ -50,6 +101,7 @@
|
|||
top-output-string
|
||||
(*volatile* " volatile "))
|
||||
|
||||
;(let ((*print-level* 3)) (pprint *top-level-forms*))
|
||||
(setq *top-level-forms* (nreverse *top-level-forms*))
|
||||
|
||||
(wt-nl1 "#include \"" h-namestring "\"")
|
||||
|
|
@ -59,7 +111,7 @@
|
|||
(*reservation-cmacro* (next-cmacro))
|
||||
(c-output-file *compiler-output1*)
|
||||
(*compiler-output1* (make-string-output-stream))
|
||||
(local-funs)
|
||||
(*emitted-local-funs* nil)
|
||||
#+PDE (optimize-space (>= *space* 3)))
|
||||
(wt-nl1 "static const char *compiler_data_text;")
|
||||
(wt-nl1 "void")
|
||||
|
|
@ -73,39 +125,13 @@
|
|||
(wt-nl "flag->cblock.data_text = compiler_data_text;")
|
||||
(wt-nl "flag->cblock.data_text_size = compiler_data_text_size;")
|
||||
(wt-nl "return;}")
|
||||
(flet ((emit-local-funs ()
|
||||
;; Local functions and closure functions
|
||||
(do ()
|
||||
;; repeat until t3local-fun generates no more
|
||||
((eq local-funs *local-funs*))
|
||||
;; scan *local-funs* backwards
|
||||
(do ((lfs *local-funs* (cdr lfs)))
|
||||
((eq (cdr lfs) local-funs)
|
||||
(setq local-funs lfs)
|
||||
(when *compile-print*
|
||||
(print-emitting (fun-name (cadar lfs))))
|
||||
(locally (declare (notinline t3local-fun))
|
||||
;; so disassemble can redefine it
|
||||
(apply 't3local-fun (car lfs))))))))
|
||||
;; useless in initialization.
|
||||
(dolist (form *top-level-forms*)
|
||||
(let ((*compile-to-linking-call* nil)
|
||||
(*env* 0) (*level* 0) (*temp* 0))
|
||||
(when (setq def (get (car form) 'T2))
|
||||
(apply def (cdr form))))
|
||||
(let ((*compiler-output1* c-output-file))
|
||||
(emit-local-funs)
|
||||
(setq *funarg-vars* nil)
|
||||
(when (setq def (get (car form) 'T3))
|
||||
;; new local functions get pushed into *local-funs*
|
||||
(when (and *compile-print*
|
||||
(member (car form)
|
||||
'(DEFUN DEFMACRO DEFCBODY) ; DEFENTRY DEFUNC
|
||||
:test #'eq))
|
||||
(print-emitting (second form)))
|
||||
(apply def (cdr form)))
|
||||
(emit-local-funs)
|
||||
(setq *funarg-vars* nil))))
|
||||
;; useless in initialization.
|
||||
(dolist (form *top-level-forms*)
|
||||
(let ((*compile-to-linking-call* nil)
|
||||
(*env* 0) (*level* 0) (*temp* 0))
|
||||
(t2expr form))
|
||||
(let ((*compiler-output1* c-output-file))
|
||||
(t3expr form)))
|
||||
(wt-function-epilogue)
|
||||
(wt-nl1 "}")
|
||||
(setq top-output-string (get-output-stream-string *compiler-output1*)))
|
||||
|
|
@ -158,8 +184,8 @@
|
|||
(cond (load-flag
|
||||
(t1progn (rest args)))
|
||||
(compile-flag
|
||||
(cmp-eval (cons 'PROGN (cdr args))))))
|
||||
)
|
||||
(cmp-eval (cons 'PROGN (cdr args)))
|
||||
'(PROGN NIL)))))
|
||||
|
||||
(defun t1compiler-let (args &aux (symbols nil) (values nil))
|
||||
(when (endp args) (too-few-args 'compiler-let 1 0))
|
||||
|
|
@ -180,7 +206,14 @@
|
|||
(setq args (progv symbols values (t1progn (cdr args))))
|
||||
)
|
||||
|
||||
(defun t1progn (args) (dolist (form args) (t1expr form)))
|
||||
(defun t1progn (args)
|
||||
(list 'PROGN (mapcar #'t1expr* args)))
|
||||
|
||||
(defun t2progn (args)
|
||||
(mapcar #'t2expr args))
|
||||
|
||||
(defun t3progn (args)
|
||||
(mapcar #'t3expr args))
|
||||
|
||||
(defun exported-fname (name)
|
||||
(or (get name 'Lfun)
|
||||
|
|
@ -193,11 +226,11 @@
|
|||
"The function name ~s is not a symbol." (car args))
|
||||
(when *compile-time-too* (cmp-eval (cons 'DEFUN args)))
|
||||
(setq *non-package-operation* t)
|
||||
(let* ((*vars* nil) (*funs* nil) (*blocks* nil) (*tags* nil) lambda-expr
|
||||
(*sharp-commas* nil) (*special-binding* nil)
|
||||
(let* (lambda-expr
|
||||
(fname (car args))
|
||||
(cfun (exported-fname fname))
|
||||
(doc nil))
|
||||
(doc nil)
|
||||
output)
|
||||
|
||||
(setq lambda-expr (c1lambda-expr (cdr args) fname))
|
||||
(unless (eql setjmps *setjmps*)
|
||||
|
|
@ -205,7 +238,7 @@
|
|||
(when (fourth lambda-expr)
|
||||
(setq doc (add-object (fourth lambda-expr))))
|
||||
(add-load-time-sharp-comma)
|
||||
(new-defun fname cfun lambda-expr doc *special-binding*)
|
||||
(setq output (new-defun fname cfun lambda-expr doc *special-binding*))
|
||||
(when
|
||||
(and
|
||||
(get fname 'PROCLAIMED-FUNCTION)
|
||||
|
|
@ -237,27 +270,24 @@
|
|||
:test #'eq))
|
||||
(make-inline-string cfun pat))
|
||||
*inline-functions*))))
|
||||
)
|
||||
)
|
||||
output))
|
||||
|
||||
;;; Mechanism for sharing code:
|
||||
(defun new-defun (fname cfun lambda-expr doc special-binding)
|
||||
(let ((previous (dolist (form *top-level-forms*)
|
||||
(let ((previous (dolist (form *global-funs*)
|
||||
(when (and (eq 'DEFUN (car form))
|
||||
(equal special-binding (sixth form))
|
||||
(similar lambda-expr (fourth form)))
|
||||
(return (third form))))))
|
||||
(equal special-binding (fifth form))
|
||||
(similar lambda-expr (third form)))
|
||||
(return (second form))))))
|
||||
(if previous
|
||||
(progn
|
||||
(cmpnote "Sharing code for function ~A" fname)
|
||||
(push (list 'DEFUN fname previous nil doc special-binding
|
||||
*funarg-vars*)
|
||||
*top-level-forms*))
|
||||
(progn
|
||||
(push (list 'DEFUN fname cfun lambda-expr doc special-binding
|
||||
*funarg-vars*)
|
||||
*top-level-forms*)
|
||||
(push (cons fname cfun) *global-funs*)))))
|
||||
(list 'DEFUN fname previous nil doc special-binding
|
||||
*funarg-vars*))
|
||||
(let ((fun-desc (list fname cfun lambda-expr doc special-binding
|
||||
*funarg-vars*)))
|
||||
(push fun-desc *global-funs*)
|
||||
(cons 'DEFUN fun-desc)))))
|
||||
|
||||
(defun similar (x y)
|
||||
(or (equal x y)
|
||||
|
|
@ -540,17 +570,13 @@
|
|||
"The macro name ~s is not a symbol." (car args))
|
||||
(cmp-eval (cons 'DEFMACRO args))
|
||||
(setq *non-package-operation* t)
|
||||
(let ((*vars* nil) (*funs* nil) (*blocks* nil) (*tags* nil)
|
||||
(*sharp-commas* nil) (*special-binding* nil)
|
||||
macro-lambda (cfun (next-cfun)) (doc nil) (ppn nil))
|
||||
(let (macro-lambda (cfun (next-cfun)) (doc nil) (ppn nil))
|
||||
(setq macro-lambda (c1dm (car args) (second args) (cddr args)))
|
||||
(when (car macro-lambda) (setq doc (add-object (car macro-lambda))))
|
||||
(when (second macro-lambda) (setq ppn (add-object (second macro-lambda))))
|
||||
(add-load-time-sharp-comma)
|
||||
(push (list 'DEFMACRO (car args) cfun (cddr macro-lambda) doc ppn
|
||||
*special-binding*)
|
||||
*top-level-forms*))
|
||||
)
|
||||
(list 'DEFMACRO (car args) cfun (cddr macro-lambda) doc ppn
|
||||
*special-binding*)))
|
||||
|
||||
(defun t2defmacro (fname cfun macro-lambda doc ppn sp
|
||||
&aux (vv (add-symbol fname)))
|
||||
|
|
@ -590,11 +616,9 @@
|
|||
(defun t1ordinary (form)
|
||||
(when *compile-time-too* (cmp-eval form))
|
||||
(setq *non-package-operation* t)
|
||||
(let ((*vars* nil) (*funs* nil) (*blocks* nil) (*tags* nil)
|
||||
(*sharp-commas* nil))
|
||||
(setq form (c1expr form))
|
||||
(add-load-time-sharp-comma)
|
||||
(push (list 'ORDINARY form) *top-level-forms*)))
|
||||
(setq form (c1expr form))
|
||||
(add-load-time-sharp-comma)
|
||||
(list 'ORDINARY form))
|
||||
|
||||
(defun t2ordinary (form)
|
||||
(let* ((*exit* (next-label)) (*unwind-exit* (list *exit*))
|
||||
|
|
@ -616,17 +640,14 @@
|
|||
(when *compile-time-too* (cmp-eval `(defvar ,@args)))
|
||||
(setq *non-package-operation* nil)
|
||||
(if (endp (cdr args))
|
||||
(push (list 'DECLARE (add-symbol name)) *top-level-forms*)
|
||||
(list 'DECLARE (add-symbol name))
|
||||
(progn
|
||||
(unless (endp (cddr args)) (setq doc (add-object (third args))))
|
||||
(let* ((*vars* nil) (*funs* nil) (*blocks* nil) (*tags* nil)
|
||||
(*sharp-commas* nil))
|
||||
(setq form (c1expr (second args)))
|
||||
(add-load-time-sharp-comma))
|
||||
(push (list 'DEFVAR (make-var :name name :kind 'SPECIAL
|
||||
:loc (add-symbol name)) form doc)
|
||||
*top-level-forms*)))
|
||||
)
|
||||
(setq form (c1expr (second args)))
|
||||
(add-load-time-sharp-comma)
|
||||
(push name *global-vars*)
|
||||
(list 'DEFVAR (make-var :name name :kind 'SPECIAL
|
||||
:loc (add-symbol name)) form doc))))
|
||||
|
||||
(defun t2defvar (var form doc &aux (vv (var-loc var)))
|
||||
(wt-nl vv "->symbol.stype=(short)stp_special;")
|
||||
|
|
@ -641,10 +662,67 @@
|
|||
(wt-nl))
|
||||
)
|
||||
|
||||
(defun t1decl-body (decls body)
|
||||
(if (null decls)
|
||||
(t1progn body)
|
||||
(let* ((*function-declarations* *function-declarations*)
|
||||
(*alien-declarations* *alien-declarations*)
|
||||
(*notinline* *notinline*)
|
||||
(*space* *space*)
|
||||
(*compiler-check-args* *compiler-check-args*)
|
||||
(*compiler-push-events* *compiler-push-events*)
|
||||
(dl (c1add-declarations decls)))
|
||||
(list 'DECL-BODY dl (t1progn body)))))
|
||||
|
||||
(defun t2decl-body (decls body)
|
||||
(let ((*compiler-check-args* *compiler-check-args*)
|
||||
(*safe-compile* *safe-compile*)
|
||||
(*compiler-push-events* *compiler-push-events*)
|
||||
(*notinline* *notinline*)
|
||||
(*space* *space*))
|
||||
(c1add-declarations decls)
|
||||
(t2expr body)))
|
||||
|
||||
(defun t3decl-body (decls body)
|
||||
(let ((*compiler-check-args* *compiler-check-args*)
|
||||
(*safe-compile* *safe-compile*)
|
||||
(*compiler-push-events* *compiler-push-events*)
|
||||
(*notinline* *notinline*)
|
||||
(*space* *space*))
|
||||
(c1add-declarations decls)
|
||||
(t3expr body)))
|
||||
|
||||
(defun t1locally (args)
|
||||
(multiple-value-bind (body ss ts is other-decl)
|
||||
(c1body args t)
|
||||
(c1add-globals ss)
|
||||
(check-vdecl nil ts is)
|
||||
(t1decl-body other-decl body)))
|
||||
|
||||
(defun t1macrolet (args &aux (*funs* *funs*))
|
||||
(when (endp args) (too-few-args 'macrolet 1 0))
|
||||
(dolist (def (car args))
|
||||
(cmpck (or (endp def) (not (symbolp (car def))) (endp (cdr def)))
|
||||
"The macro definition ~s is illegal." def)
|
||||
(push (list (car def)
|
||||
'MACRO
|
||||
(si::make-lambda (car def)
|
||||
(cdr (sys::expand-defmacro (car def) (second def) (cddr def)))))
|
||||
*funs*))
|
||||
(t1locally (cdr args)))
|
||||
|
||||
(defun t1symbol-macrolet (args &aux (*vars* *vars*))
|
||||
(when (endp args) (too-few-args 'symbol-macrolet 1 0))
|
||||
(dolist (def (car args))
|
||||
(cmpck (or (endp def) (not (symbolp (car def))) (endp (cdr def)))
|
||||
"The symbol-macro definition ~s is illegal." def)
|
||||
(push def *vars*))
|
||||
(t1locally (cdr args)))
|
||||
|
||||
(defun t1clines (args)
|
||||
(dolist (s args)
|
||||
(cmpck (not (stringp s)) "The argument to CLINE, ~s, is not a string." s))
|
||||
(push (list 'CLINES args) *top-level-forms*))
|
||||
(list 'CLINES args))
|
||||
|
||||
(defun t3clines (ss) (dolist (s ss) (wt-nl1 s)))
|
||||
|
||||
|
|
@ -939,12 +1017,8 @@
|
|||
(setq fun (first args))
|
||||
(cmpck (not (symbolp fun))
|
||||
"The function name ~s is not a symbol." fun)
|
||||
(push (list 'DEFCBODY fun cfun (second args) (third args)
|
||||
(fourth args))
|
||||
*top-level-forms*)
|
||||
(push (cons fun cfun) *global-funs*)
|
||||
)
|
||||
|
||||
(push (list fun cfun) *global-funs*)
|
||||
(list 'DEFCBODY fun cfun (second args) (third args) (fourth args)))
|
||||
|
||||
(defun t2defCbody (fname cfun arg-types type body
|
||||
&aux (vv (add-symbol fname)))
|
||||
|
|
@ -1179,6 +1253,9 @@
|
|||
(setf (get 'DEFUN 'T1) #'t1defun)
|
||||
(setf (get 'DEFMACRO 'T1) #'t1defmacro)
|
||||
(setf (get 'DEFVAR 'T1) #'t1defvar)
|
||||
(setf (get 'MACROLET 'T1) #'t1macrolet)
|
||||
(setf (get 'LOCALLY 'T1) #'t1locally)
|
||||
(setf (get 'SYMBOL-MACROLET 'T1) #'t1symbol-macrolet)
|
||||
(setf (get 'CLINES 'T1) 't1clines)
|
||||
(setf (get 'DEFCFUN 'T1) 't1defcfun)
|
||||
;(setf (get 'DEFENTRY 'T1) 't1defentry)
|
||||
|
|
@ -1188,6 +1265,8 @@
|
|||
|
||||
;;; Pass 2 initializers.
|
||||
|
||||
(setf (get 'DECL-BODY 't2) #'t2decl-body)
|
||||
(setf (get 'PROGN 'T2) #'t2progn)
|
||||
(setf (get 'DEFUN 'T2) #'t2defun)
|
||||
(setf (get 'DEFMACRO 'T2) #'t2defmacro)
|
||||
(setf (get 'ORDINARY 'T2) #'t2ordinary)
|
||||
|
|
@ -1201,6 +1280,8 @@
|
|||
|
||||
;;; Pass 2 C function generators.
|
||||
|
||||
(setf (get 'DECL-BODY 't3) #'t3decl-body)
|
||||
(setf (get 'PROGN 'T3) #'t3progn)
|
||||
(setf (get 'DEFUN 'T3) #'t3defun)
|
||||
(setf (get 'DEFMACRO 'T3) #'t3defmacro)
|
||||
(setf (get 'CLINES 'T3) 't3clines)
|
||||
|
|
|
|||
|
|
@ -59,14 +59,7 @@
|
|||
;;; value.
|
||||
|
||||
(defun check-global (name)
|
||||
(let ((x (assoc name *objects*)))
|
||||
(when x
|
||||
(dolist (tlf *top-level-forms*)
|
||||
(when (or (and (eq (car tlf) 'DEFVAR)
|
||||
(equalp (var-loc (second tlf)) (second x)))
|
||||
(and (eq (car tlf) 'DECLARE)
|
||||
(equalp (second tlf) (second x))))
|
||||
(return tlf))))))
|
||||
(member name *global-vars* :test #'eq))
|
||||
|
||||
;;;
|
||||
;;; Check if the symbol has a symbol macro
|
||||
|
|
|
|||
|
|
@ -138,12 +138,14 @@
|
|||
(defun wt-data-package-operation (form)
|
||||
(ecase (car form)
|
||||
(si::select-package
|
||||
(t1ordinary form)
|
||||
(cmp-eval form)
|
||||
(let ((package-name (cadr form)))
|
||||
(setq *compiler-package* (si::select-package package-name))
|
||||
#+nil(wt-filtered-data (format nil "#!0 ~s" (string package-name)))))
|
||||
(let ((output (t1ordinary form)))
|
||||
(cmp-eval form)
|
||||
(let ((package-name (cadr form)))
|
||||
(setq *compiler-package* (si::select-package package-name)))
|
||||
output))
|
||||
;#+nil(wt-filtered-data (format nil "#!0 ~s" (string package-name)))))
|
||||
(si::%defpackage
|
||||
(t1ordinary `(eval ',form))
|
||||
(wt-filtered-data (format nil "#!1 ~s" (second form)))
|
||||
(cmp-eval form))))
|
||||
(let ((output (t1ordinary `(eval ',form))))
|
||||
(wt-filtered-data (format nil "#!1 ~s" (second form)))
|
||||
(cmp-eval form)
|
||||
output))))
|
||||
|
|
@ -164,6 +164,7 @@
|
|||
ldb
|
||||
ldb-test
|
||||
lisp-implementation-type
|
||||
locally
|
||||
logandc1
|
||||
logandc2
|
||||
logical-pathname-translations
|
||||
|
|
|
|||
|
|
@ -14,13 +14,13 @@
|
|||
(in-package "SYSTEM")
|
||||
|
||||
(c-declaim (si::c-export-fname reduce fill replace
|
||||
;remove remove-if remove-if-not
|
||||
;delete delete-if delete-if-not
|
||||
;count count-if count-if-not
|
||||
;substitute substitute-if substitute-if-not
|
||||
;nsubstitute nsubstitute-if nsubstitute-if-not
|
||||
;find find-if find-if-not
|
||||
;position position-if position-if-not
|
||||
remove remove-if remove-if-not
|
||||
delete delete-if delete-if-not
|
||||
count count-if count-if-not
|
||||
substitute substitute-if substitute-if-not
|
||||
nsubstitute nsubstitute-if nsubstitute-if-not
|
||||
find find-if find-if-not
|
||||
position position-if position-if-not
|
||||
remove-duplicates delete-duplicates
|
||||
mismatch search sort stable-sort merge))
|
||||
|
||||
|
|
@ -223,7 +223,7 @@
|
|||
:key key))
|
||||
',f)
|
||||
`(',f)))))
|
||||
) ; eval-when
|
||||
; eval-when
|
||||
|
||||
|
||||
(defseq remove () t nil t
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue