[Top][All Lists]
[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Gcl-commits] gcl debianchangelog clcs/gcl_clcs_condition_def...
|
From: |
Camm Maguire |
|
Subject: |
[Gcl-commits] gcl debianchangelog clcs/gcl_clcs_condition_def... |
|
Date: |
Mon, 05 Jun 2006 22:02:46 +0000 |
CVSROOT: /cvsroot/gcl
Module name: gcl
Changes by: Camm Maguire <camm> 06/06/05 22:02:46
Modified files:
debian : changelog
clcs : gcl_clcs_condition_definitions.lisp
gcl_clcs_debugger.lisp gcl_clcs_install.lisp
gcl_clcs_top_patches.lisp makefile package.lisp
sys-proclaim.lisp
cmpnew : gcl_cmpenv.lsp gcl_cmpeval.lsp gcl_cmpfun.lsp
gcl_cmpinline.lsp gcl_cmplet.lsp
gcl_cmpmain.lsp gcl_cmpmulti.lsp gcl_cmpopt.lsp
gcl_cmpspecial.lsp gcl_cmptop.lsp
gcl_cmptype.lsp gcl_cmputil.lsp gcl_cmpvar.lsp
gcl_cmpwt.lsp gcl_fasdmacros.lsp
gcl_lfun_list.lsp
lsp : gcl_arraylib.lsp gcl_defmacro.lsp
gcl_defstruct.lsp gcl_evalmacros.lsp
gcl_iolib.lsp gcl_loadcmp.lsp gcl_mislib.lsp
gcl_module.lsp gcl_setf.lsp gcl_top.lsp
makefile
o : assignment.c fasdump.c file.d funlink.c read.d
reference.c toplevel.c
pcl : gcl_pcl_std_class.lisp makefile
unixport : init_ansi_gcl.lsp.in init_gcl.lsp.in
init_mod_gcl.lsp.in init_pcl_gcl.lsp.in
init_pre_gcl.lsp.in makefile sys_ansi_gcl.c
sys_gcl.c sys_mod_gcl.c sys_pcl_gcl.c
sys_pre_gcl.c
Added files:
lsp : gcl_callhash.lsp
Log message:
auto-recompilation support
CVSWeb URLs:
http://cvs.savannah.gnu.org/viewcvs/gcl/debian/changelog?cvsroot=gcl&r1=1.1084&r2=1.1085
http://cvs.savannah.gnu.org/viewcvs/gcl/clcs/gcl_clcs_condition_definitions.lisp?cvsroot=gcl&r1=1.7&r2=1.8
http://cvs.savannah.gnu.org/viewcvs/gcl/clcs/gcl_clcs_debugger.lisp?cvsroot=gcl&r1=1.2&r2=1.3
http://cvs.savannah.gnu.org/viewcvs/gcl/clcs/gcl_clcs_install.lisp?cvsroot=gcl&r1=1.4&r2=1.5
http://cvs.savannah.gnu.org/viewcvs/gcl/clcs/gcl_clcs_top_patches.lisp?cvsroot=gcl&r1=1.3&r2=1.4
http://cvs.savannah.gnu.org/viewcvs/gcl/clcs/makefile?cvsroot=gcl&r1=1.25&r2=1.26
http://cvs.savannah.gnu.org/viewcvs/gcl/clcs/package.lisp?cvsroot=gcl&r1=1.4&r2=1.5
http://cvs.savannah.gnu.org/viewcvs/gcl/clcs/sys-proclaim.lisp?cvsroot=gcl&r1=1.5&r2=1.6
http://cvs.savannah.gnu.org/viewcvs/gcl/cmpnew/gcl_cmpenv.lsp?cvsroot=gcl&r1=1.23&r2=1.24
http://cvs.savannah.gnu.org/viewcvs/gcl/cmpnew/gcl_cmpeval.lsp?cvsroot=gcl&r1=1.54&r2=1.55
http://cvs.savannah.gnu.org/viewcvs/gcl/cmpnew/gcl_cmpfun.lsp?cvsroot=gcl&r1=1.29&r2=1.30
http://cvs.savannah.gnu.org/viewcvs/gcl/cmpnew/gcl_cmpinline.lsp?cvsroot=gcl&r1=1.40&r2=1.41
http://cvs.savannah.gnu.org/viewcvs/gcl/cmpnew/gcl_cmplet.lsp?cvsroot=gcl&r1=1.24&r2=1.25
http://cvs.savannah.gnu.org/viewcvs/gcl/cmpnew/gcl_cmpmain.lsp?cvsroot=gcl&r1=1.47&r2=1.48
http://cvs.savannah.gnu.org/viewcvs/gcl/cmpnew/gcl_cmpmulti.lsp?cvsroot=gcl&r1=1.19&r2=1.20
http://cvs.savannah.gnu.org/viewcvs/gcl/cmpnew/gcl_cmpopt.lsp?cvsroot=gcl&r1=1.32&r2=1.33
http://cvs.savannah.gnu.org/viewcvs/gcl/cmpnew/gcl_cmpspecial.lsp?cvsroot=gcl&r1=1.12&r2=1.13
http://cvs.savannah.gnu.org/viewcvs/gcl/cmpnew/gcl_cmptop.lsp?cvsroot=gcl&r1=1.34&r2=1.35
http://cvs.savannah.gnu.org/viewcvs/gcl/cmpnew/gcl_cmptype.lsp?cvsroot=gcl&r1=1.32&r2=1.33
http://cvs.savannah.gnu.org/viewcvs/gcl/cmpnew/gcl_cmputil.lsp?cvsroot=gcl&r1=1.6&r2=1.7
http://cvs.savannah.gnu.org/viewcvs/gcl/cmpnew/gcl_cmpvar.lsp?cvsroot=gcl&r1=1.16&r2=1.17
http://cvs.savannah.gnu.org/viewcvs/gcl/cmpnew/gcl_cmpwt.lsp?cvsroot=gcl&r1=1.5&r2=1.6
http://cvs.savannah.gnu.org/viewcvs/gcl/cmpnew/gcl_fasdmacros.lsp?cvsroot=gcl&r1=1.3&r2=1.4
http://cvs.savannah.gnu.org/viewcvs/gcl/cmpnew/gcl_lfun_list.lsp?cvsroot=gcl&r1=1.10&r2=1.11
http://cvs.savannah.gnu.org/viewcvs/gcl/lsp/gcl_arraylib.lsp?cvsroot=gcl&r1=1.10&r2=1.11
http://cvs.savannah.gnu.org/viewcvs/gcl/lsp/gcl_defmacro.lsp?cvsroot=gcl&r1=1.6&r2=1.7
http://cvs.savannah.gnu.org/viewcvs/gcl/lsp/gcl_defstruct.lsp?cvsroot=gcl&r1=1.10&r2=1.11
http://cvs.savannah.gnu.org/viewcvs/gcl/lsp/gcl_evalmacros.lsp?cvsroot=gcl&r1=1.19&r2=1.20
http://cvs.savannah.gnu.org/viewcvs/gcl/lsp/gcl_iolib.lsp?cvsroot=gcl&r1=1.11&r2=1.12
http://cvs.savannah.gnu.org/viewcvs/gcl/lsp/gcl_loadcmp.lsp?cvsroot=gcl&r1=1.3&r2=1.4
http://cvs.savannah.gnu.org/viewcvs/gcl/lsp/gcl_mislib.lsp?cvsroot=gcl&r1=1.14&r2=1.15
http://cvs.savannah.gnu.org/viewcvs/gcl/lsp/gcl_module.lsp?cvsroot=gcl&r1=1.6&r2=1.7
http://cvs.savannah.gnu.org/viewcvs/gcl/lsp/gcl_setf.lsp?cvsroot=gcl&r1=1.17&r2=1.18
http://cvs.savannah.gnu.org/viewcvs/gcl/lsp/gcl_top.lsp?cvsroot=gcl&r1=1.16&r2=1.17
http://cvs.savannah.gnu.org/viewcvs/gcl/lsp/makefile?cvsroot=gcl&r1=1.26&r2=1.27
http://cvs.savannah.gnu.org/viewcvs/gcl/lsp/gcl_callhash.lsp?cvsroot=gcl&rev=1.1
http://cvs.savannah.gnu.org/viewcvs/gcl/o/assignment.c?cvsroot=gcl&r1=1.20&r2=1.21
http://cvs.savannah.gnu.org/viewcvs/gcl/o/fasdump.c?cvsroot=gcl&r1=1.16&r2=1.17
http://cvs.savannah.gnu.org/viewcvs/gcl/o/file.d?cvsroot=gcl&r1=1.61&r2=1.62
http://cvs.savannah.gnu.org/viewcvs/gcl/o/funlink.c?cvsroot=gcl&r1=1.26&r2=1.27
http://cvs.savannah.gnu.org/viewcvs/gcl/o/read.d?cvsroot=gcl&r1=1.42&r2=1.43
http://cvs.savannah.gnu.org/viewcvs/gcl/o/reference.c?cvsroot=gcl&r1=1.13&r2=1.14
http://cvs.savannah.gnu.org/viewcvs/gcl/o/toplevel.c?cvsroot=gcl&r1=1.13&r2=1.14
http://cvs.savannah.gnu.org/viewcvs/gcl/pcl/gcl_pcl_std_class.lisp?cvsroot=gcl&r1=1.2&r2=1.3
http://cvs.savannah.gnu.org/viewcvs/gcl/pcl/makefile?cvsroot=gcl&r1=1.21&r2=1.22
http://cvs.savannah.gnu.org/viewcvs/gcl/unixport/init_ansi_gcl.lsp.in?cvsroot=gcl&r1=1.25&r2=1.26
http://cvs.savannah.gnu.org/viewcvs/gcl/unixport/init_gcl.lsp.in?cvsroot=gcl&r1=1.23&r2=1.24
http://cvs.savannah.gnu.org/viewcvs/gcl/unixport/init_mod_gcl.lsp.in?cvsroot=gcl&r1=1.10&r2=1.11
http://cvs.savannah.gnu.org/viewcvs/gcl/unixport/init_pcl_gcl.lsp.in?cvsroot=gcl&r1=1.15&r2=1.16
http://cvs.savannah.gnu.org/viewcvs/gcl/unixport/init_pre_gcl.lsp.in?cvsroot=gcl&r1=1.12&r2=1.13
http://cvs.savannah.gnu.org/viewcvs/gcl/unixport/makefile?cvsroot=gcl&r1=1.71&r2=1.72
http://cvs.savannah.gnu.org/viewcvs/gcl/unixport/sys_ansi_gcl.c?cvsroot=gcl&r1=1.15&r2=1.16
http://cvs.savannah.gnu.org/viewcvs/gcl/unixport/sys_gcl.c?cvsroot=gcl&r1=1.23&r2=1.24
http://cvs.savannah.gnu.org/viewcvs/gcl/unixport/sys_mod_gcl.c?cvsroot=gcl&r1=1.10&r2=1.11
http://cvs.savannah.gnu.org/viewcvs/gcl/unixport/sys_pcl_gcl.c?cvsroot=gcl&r1=1.14&r2=1.15
http://cvs.savannah.gnu.org/viewcvs/gcl/unixport/sys_pre_gcl.c?cvsroot=gcl&r1=1.10&r2=1.11
Patches:
Index: debian/changelog
===================================================================
RCS file: /cvsroot/gcl/gcl/debian/changelog,v
retrieving revision 1.1084
retrieving revision 1.1085
diff -u -b -r1.1084 -r1.1085
--- debian/changelog 16 May 2006 21:46:16 -0000 1.1084
+++ debian/changelog 5 Jun 2006 22:02:45 -0000 1.1085
@@ -171,8 +171,9 @@
* test support for si::factorial from gmp mpz_fac_ui, fix
gmp_randinit_default handling for gmp 4.2
* call-lambda info-type propagation
+ * auto-recompilation support
- -- Camm Maguire <address@hidden> Tue, 16 May 2006 21:46:05 +0000
+ -- Camm Maguire <address@hidden> Mon, 5 Jun 2006 22:01:13 +0000
gclcvs (2.7.0-53) unstable; urgency=low
Index: clcs/gcl_clcs_condition_definitions.lisp
===================================================================
RCS file: /cvsroot/gcl/gcl/clcs/gcl_clcs_condition_definitions.lisp,v
retrieving revision 1.7
retrieving revision 1.8
diff -u -b -r1.7 -r1.8
--- clcs/gcl_clcs_condition_definitions.lisp 15 Oct 2005 02:39:26 -0000
1.7
+++ clcs/gcl_clcs_condition_definitions.lisp 5 Jun 2006 22:02:45 -0000
1.8
@@ -176,10 +176,14 @@
(CELL-ERROR-NAME CONDITION)))))
(DEFINE-CONDITION UNBOUND-SLOT (CELL-ERROR)
- ()
- (:REPORT (LAMBDA (CONDITION STREAM)
- (FORMAT STREAM "The slot ~S is unbound."
- (CELL-ERROR-NAME CONDITION)))))
+ ((instance :initarg :instance :accessor unbound-slot-instance))
+ (:report (lambda (c s) (format s "Slot ~s is unbound in ~s"
+ (cell-error-name c)
+ (unbound-slot-instance c)))))
+;; ()
+;; (:REPORT (LAMBDA (CONDITION STREAM)
+;; (FORMAT STREAM "The slot ~S is unbound."
+;; (CELL-ERROR-NAME CONDITION)))))
(DEFINE-CONDITION UNDEFINED-FUNCTION (CELL-ERROR)
()
Index: clcs/gcl_clcs_debugger.lisp
===================================================================
RCS file: /cvsroot/gcl/gcl/clcs/gcl_clcs_debugger.lisp,v
retrieving revision 1.2
retrieving revision 1.3
diff -u -b -r1.2 -r1.3
--- clcs/gcl_clcs_debugger.lisp 7 May 2005 02:52:28 -0000 1.2
+++ clcs/gcl_clcs_debugger.lisp 5 Jun 2006 22:02:45 -0000 1.3
@@ -96,7 +96,8 @@
(LET ((HOOK *DEBUGGER-HOOK*)
(*DEBUGGER-HOOK* NIL))
(FUNCALL HOOK CONDITION HOOK)))
- (funcall *debugger-function* CONDITION)))
+ (funcall *debugger-function* CONDITION)
+ (values)));FIXME nil return types
(DEFUN STANDARD-DEBUGGER (CONDITION)
(LET* ((*DEBUG-LEVEL* (1+ *DEBUG-LEVEL*))
Index: clcs/gcl_clcs_install.lisp
===================================================================
RCS file: /cvsroot/gcl/gcl/clcs/gcl_clcs_install.lisp,v
retrieving revision 1.4
retrieving revision 1.5
diff -u -b -r1.4 -r1.5
--- clcs/gcl_clcs_install.lisp 18 Oct 2005 02:12:10 -0000 1.4
+++ clcs/gcl_clcs_install.lisp 5 Jun 2006 22:02:45 -0000 1.5
@@ -21,15 +21,16 @@
(setf (symbol-function real)
(get real 'definition-before-clcs))))
+;FIXME
(defvar *clcs-redefinitions*
(nconc (mapcar #'(lambda (symbol)
(list (intern (symbol-name symbol) "LISP") symbol))
*shadowed-symbols*)
- '((compile-file clcs-compile-file)
- (compile clcs-compile)
- (load clcs-load)
- (open clcs-open)
- #+kcl (si::break-level si::clcs-break-level)
+ '(;(compile-file clcs-compile-file)
+; (compile clcs-compile)
+; (load clcs-load)
+; (open clcs-open)
+; #+kcl (si::break-level si::clcs-break-level)
#+kcl (si::terminal-interrupt si::clcs-terminal-interrupt)
#+kcl (si::break-quit si::clcs-break-quit)
#+kcl (si::error-set clcs-error-set)
@@ -45,37 +46,85 @@
(revert-symbol (first r)))
nil)
-(defun clcs-compile-file (file &rest args)
- (loop (with-simple-restart (retry "Retry compiling file ~S." file)
- (let ((values (multiple-value-list
- (apply (or (get 'compile-file
'definition-before-clcs)
- #'compile-file)
- file args))))
- (unless #+kcl compiler::*error-p* #-kcl nil
- (return-from clcs-compile-file
- (values-list values)))
- (error "~S failed." 'compile-file)))))
-
-(defun clcs-compile (&rest args)
- (loop (with-simple-restart (retry "Retry compiling ~S." (car args))
- (let ((values (multiple-value-list
- (apply (or (get 'compile 'definition-before-clcs)
- #'compile-file)
- args))))
- (unless #+kcl compiler::*error-p* #-kcl nil
- (return-from clcs-compile
- (values-list values)))
- (error "~S failed." 'compile)))))
-
-(defun clcs-load (&rest args)
- (loop (with-simple-restart (retry "Retry loading file ~S." (car args))
- (return-from clcs-load
- (apply (or (get 'load 'definition-before-clcs) #'load)
args)))))
-
-(defun clcs-open (&rest args)
- (loop (with-simple-restart (retry "Retry opening file ~S." (car args))
- (return-from clcs-open
- (apply (or (get 'open 'definition-before-clcs) #'open)
args)))))
+(defun compile-file (file &rest args)
+ (let (warnings failures)
+ (handler-bind
+ ((warning (lambda (c)
+ (setq warnings t)
+ (unless (typep c 'style-warning)
+ (setq failures t))
+ (when (not compiler::*compile-verbose*)
+ (invoke-restart (find-restart 'muffle-warning c)))))
+ (error (lambda (c)
+ (declare (ignore c))
+ (setq failures t))))
+ (loop
+ (with-simple-restart
+ (retry "Retry compiling file ~S." file)
+ (let ((res (apply #.(si::function-src 'compile-file) file args)))
+ (when compiler::*error-p* (error "Compilation of ~s failed." file))
+ (return (values res warnings failures))))))))
+
+;(defun clcs-compile-file (file &rest args)
+; (loop (with-simple-restart (retry "Retry compiling file ~S." file)
+; (let ((values (multiple-value-list
+; (apply (or (get 'compile-file
'definition-before-clcs)
+; #'compile-file)
+; file args))))
+; (unless #+kcl compiler::*error-p* #-kcl nil
+; (return-from clcs-compile-file
+; (values-list values)))
+; (error "~S failed." 'compile-file)))))
+
+(defun compile (name &rest args)
+ (let (warnings failures)
+ (handler-bind
+ ((warning (lambda (c)
+ (setq warnings t)
+ (unless (typep c 'style-warning)
+ (setq failures t))
+ (when (not compiler::*compile-verbose*)
+ (invoke-restart (find-restart 'muffle-warning c)))))
+ (error (lambda (c)
+ (declare (ignore c))
+ (setq failures t))))
+ (loop
+ (with-simple-restart
+ (retry "Retry compiling ~S." (cons name args))
+ (let ((res (apply #.(si::function-src 'compile) name args)))
+ (when compiler::*error-p* (error "Compilation of ~s failed." (cons
name args)))
+ (return (values res warnings failures))))))))
+
+;(defun clcs-compile (&rest args)
+; (loop (with-simple-restart (retry "Retry compiling ~S." (car args))
+; (let ((values (multiple-value-list
+; (apply (or (get 'compile 'definition-before-clcs)
+; #'compile-file)
+; args))))
+; (unless #+kcl compiler::*error-p* #-kcl nil
+; (return-from clcs-compile
+; (values-list values)))
+; (error "~S failed." 'compile)))))
+
+(defun load (&rest args)
+ (loop (with-simple-restart
+ (retry "Retry loading file ~S." (car args))
+ (return (apply #.(si::function-src 'load) args)))))
+
+(defun open (&rest args)
+ (loop (with-simple-restart
+ (retry "Retry opening file ~S." (car args))
+ (return (apply #.(si::function-src 'open) args)))))
+
+;(defun clcs-load (&rest args)
+; (loop (with-simple-restart (retry "Retry loading file ~S." (car args))
+; (return-from clcs-load
+; (apply (or (get 'load 'definition-before-clcs) #'load)
args)))))
+
+;(defun clcs-open (&rest args)
+; (loop (with-simple-restart (retry "Retry opening file ~S." (car args))
+; (return-from clcs-open
+; (apply (or (get 'open 'definition-before-clcs) #'open)
args)))))
#+(or kcl lucid cmu)
(install-clcs-symbols)
Index: clcs/gcl_clcs_top_patches.lisp
===================================================================
RCS file: /cvsroot/gcl/gcl/clcs/gcl_clcs_top_patches.lisp,v
retrieving revision 1.3
retrieving revision 1.4
diff -u -b -r1.3 -r1.4
--- clcs/gcl_clcs_top_patches.lisp 29 Jun 2005 22:04:17 -0000 1.3
+++ clcs/gcl_clcs_top_patches.lisp 5 Jun 2006 22:02:45 -0000 1.4
@@ -41,8 +41,9 @@
(T
(FORMAT T "~&No such restart."))))
+;;FIXME -- ooverwrite others directly too
;; From akcl-1-530, changes marked with ;***
-(defun clcs-break-level (at &optional env)
+(defun break-level (at &optional env)
(let* ((*break-message* (if (or (stringp at) (conditionp at)) ;***
at *break-message*)) ;***
(*quit-tags* (cons (cons *break-level* *quit-tag*) *quit-tags*)) ;***
Index: clcs/makefile
===================================================================
RCS file: /cvsroot/gcl/gcl/clcs/makefile,v
retrieving revision 1.25
retrieving revision 1.26
diff -u -b -r1.25 -r1.26
--- clcs/makefile 24 Mar 2006 03:57:00 -0000 1.25
+++ clcs/makefile 5 Jun 2006 22:02:45 -0000 1.26
@@ -9,7 +9,7 @@
#all: $(addsuffix .o,$(FILES))
saved_clcs_gcl: ../unixport/saved_pcl_gcl
- echo '(load "myload.lisp")(si::save-system "$@")' | $< $(<D)/
$(LISPFLAGS)
+ echo '(load "myload.lisp")(setq si::*disable-recompile*
t)(si::save-system "$@")' | $< $(<D)/ $(LISPFLAGS)
%.h %.data %.c : %.lisp saved_clcs_gcl
cp ../h/cmpinclude.h .
Index: clcs/package.lisp
===================================================================
RCS file: /cvsroot/gcl/gcl/clcs/package.lisp,v
retrieving revision 1.4
retrieving revision 1.5
diff -u -b -r1.4 -r1.5
--- clcs/package.lisp 21 Mar 2006 22:19:38 -0000 1.4
+++ clcs/package.lisp 5 Jun 2006 22:02:45 -0000 1.5
@@ -36,7 +36,7 @@
STORAGE-CONDITION STACK-OVERFLOW STORAGE-EXHAUSTED TYPE-ERROR
TYPE-ERROR-DATUM TYPE-ERROR-EXPECTED-TYPE SIMPLE-TYPE-ERROR
PROGRAM-ERROR CONTROL-ERROR STREAM-ERROR STREAM-ERROR-STREAM
- END-OF-FILE FILE-ERROR FILE-ERROR-PATHNAME CELL-ERROR
+ END-OF-FILE FILE-ERROR FILE-ERROR-PATHNAME CELL-ERROR CELL-ERROR-NAME
UNBOUND-VARIABLE UNDEFINED-FUNCTION ARITHMETIC-ERROR
ARITHMETIC-ERROR-OPERATION ARITHMETIC-ERROR-OPERANDS
PACKAGE-ERROR PACKAGE-ERROR-PACKAGE
Index: clcs/sys-proclaim.lisp
===================================================================
RCS file: /cvsroot/gcl/gcl/clcs/sys-proclaim.lisp,v
retrieving revision 1.5
retrieving revision 1.6
diff -u -b -r1.5 -r1.6
--- clcs/sys-proclaim.lisp 21 Mar 2006 22:19:38 -0000 1.5
+++ clcs/sys-proclaim.lisp 5 Jun 2006 22:02:45 -0000 1.6
@@ -33,7 +33,8 @@
'(FTYPE (FUNCTION NIL T) READ-EVALUATED-FORM INSTALL-CLCS-SYMBOLS
REVERT-CLCS-SYMBOLS INITIALIZE-INTERNAL-ERROR-TABLE
KCL-TOP-RESTARTS READ-DEBUG-COMMAND))
-(PROCLAIM '(FTYPE (FUNCTION (*) *) CLCS-COMPILE INVOKE-DEBUGGER))
+(PROCLAIM '(FTYPE (FUNCTION (*) nil) INVOKE-DEBUGGER)) ;FIXME nil return types
+(PROCLAIM '(FTYPE (FUNCTION (*) *) CLCS-COMPILE))
(PROCLAIM
'(FTYPE (FUNCTION (T) *) COMPILER::CMP-TOPLEVEL-EVAL
SIMPLE-ASSERTION-FAILURE INVOKE-RESTART-INTERACTIVELY
Index: cmpnew/gcl_cmpenv.lsp
===================================================================
RCS file: /cvsroot/gcl/gcl/cmpnew/gcl_cmpenv.lsp,v
retrieving revision 1.23
retrieving revision 1.24
diff -u -b -r1.23 -r1.24
--- cmpnew/gcl_cmpenv.lsp 16 May 2006 16:38:45 -0000 1.23
+++ cmpnew/gcl_cmpenv.lsp 5 Jun 2006 22:02:45 -0000 1.24
@@ -33,7 +33,7 @@
;;; If *safe-compile* is ON, some kind of run-time checks are not
;;; included in the compiled code. The default value is OFF.
-
+(defvar *portable-source*)
(defun init-env ()
(setq *next-cvar* 0)
@@ -56,6 +56,8 @@
(setq *inline-functions* nil)
(setq *inline-blocks* 0)
(setq *notinline* nil)
+ (setq *eval-when-compile-only-macros* nil)
+ (setq *portable-source* nil)
(clrhash *norm-tp-hash*)
(clrhash *and-tp-hash*)
(clrhash *or-tp-hash*))
@@ -143,6 +145,27 @@
;;; ( {type}* [ &optional {type}* ] [ &rest type ] [ &key {type}* ] )
;;; though &optional, &rest, and &key return types are simply ignored.
+(defun t-to-nil (x)
+ (if (eq x t) nil x))
+
+(defun nil-to-t (x)
+ (if x x t))
+
+(defun is-global-arg-type (x)
+ (let ((x (promoted-c-type x)))
+ (or (eq x t) (member x +c-global-arg-types+))))
+(defun is-local-arg-type (x)
+ (let ((x (promoted-c-type x)))
+ (or (eq x t) (member x +c-local-arg-types+))))
+(defun is-local-var-type (x)
+ (let ((x (promoted-c-type x)))
+ (or (eq x t) (member x +c-local-var-types+))))
+
+(defun coerce-to-one-value (type)
+ (cond ((and (consp type) (eq (car type) 'values)) (coerce-to-one-value (cadr
type)))
+ ((eq type '*))
+ (type)))
+
(defun function-arg-types (arg-types &aux vararg (types nil) result)
(setq result
(do ((al arg-types (cdr al))
@@ -159,7 +182,7 @@
((< i 9)
(let ((tem
(type-filter (car al))))
- (if (is-local-arg-type tem) tem t)))
+ (if (is-local-arg-type tem) (nil-to-t (car
al)) t)));FIXME
(t (if (eq (car al) '*) '* t)))
types)))
;;only type t args for var arg so far.
@@ -188,7 +211,7 @@
(nreverse result))
(let ((tem (if (eq (car v) '*) '* (type-filter (car v)))))
(unless (or (eq tem '*) (is-local-arg-type tem)) (setq tem t))
- (push tem result))))))
+ (push (or (car (member tem '(* t))) (car v)) result))))));FIXME
(defun put-procls (fname arg-types return-types procl)
Index: cmpnew/gcl_cmpeval.lsp
===================================================================
RCS file: /cvsroot/gcl/gcl/cmpnew/gcl_cmpeval.lsp,v
retrieving revision 1.54
retrieving revision 1.55
diff -u -b -r1.54 -r1.55
--- cmpnew/gcl_cmpeval.lsp 16 May 2006 16:38:45 -0000 1.54
+++ cmpnew/gcl_cmpeval.lsp 5 Jun 2006 22:02:45 -0000 1.55
@@ -306,6 +306,18 @@
(si::putprop 'gcd (function binary-nest) 'si::compiler-macro-prop)
(si::putprop 'lcm (function binary-nest) 'si::compiler-macro-prop)
+;FIXME apply-expander
+(defun funcall-expander (form env);FIXME inlinable-fn?
+ (declare (ignore env))
+ (cond ((and (consp (cadr form)) (eq (caadr form) 'lambda)) (cdr form))
+ ((and (consp (cadr form)) (eq (caadr form) 'function)
+ (or (symbolp (cadadr form))
+ (and (consp (cadadr form)) (eq (car (cadadr form)) 'lambda))))
+ `(,(cadadr form) ,@(cddr form)))
+ ((constantp (cadr form)) `(,(cmp-eval (cadr form)) ,@(cddr form)))
+ (form)))
+(si::putprop 'funcall (function funcall-expander) 'si::compiler-macro-prop)
+
(defun last-expander (form env)
(declare (ignore env))
(if (or (not (cdr form)) (cdddr form)) form
@@ -439,10 +451,6 @@
(setq ,x (cons (car ,s) ,x))))))))
(si::putprop 'reverse (function reverse-expander) 'si::compiler-macro-prop)
-(defun cmp-vec-length (x)
- (declare (vector x))
- (if (array-has-fill-pointer-p x) (fill-pointer x) (array-dimension x 0)))
-
(defmacro with-var-form-type ((v f tp) &rest body)
``(let ((,,v ,,f))
,@(when *compiler-check-args* `((check-type ,,v ,,tp)))
@@ -1099,6 +1107,14 @@
(cons (bind-all-vars (caddr form))
(if (cadddr form) (list (bind-all-vars (cadddr form))))))))
+;FIXME find a better way to avoid expander recursion
+(defconstant +cmp-fn-alist+ '((cmp-nthcdr . nthcdr)
+ (cmp-nth . nth)
+ (cmp-aref . row-major-aref)
+ (cmp-aset . si::aset1)
+; (cmp-array-element-type . si::array-element-type)
+ (cmp-array-dimension . array-dimension)))
+
(defun c1symbol-fun (fname args &aux fd)
(cond ((setq fd (get fname 'c1special)) (funcall fd args))
((and (setq fd (get fname 'co1special))
@@ -1153,9 +1169,22 @@
(and *record-call-info* (record-call-info 'record-call-info
fname))
nil))
+
;;continue
((setq fd (macro-function fname))
(c1expr (cmp-expand-macro fd fname args)))
+ ((when (and (member (first *current-form*) '(defun))
+ (symbolp (second *current-form*))
+ (symbol-package (second *current-form*)))
+ (si::add-hash (second *current-form*)
+ nil
+ (let ((fname (or (cdr (assoc fname +cmp-fn-alist+))
fname)))
+ (list (cons fname
+ (let* ((at (get fname
'proclaimed-arg-types))
+ (rt (get fname
'proclaimed-return-type))
+ (rt (if (equal '(*) rt) '* rt)))
+ (when (or at rt) (list at rt))))))
+ nil)))
((and (setq fd (get fname 'si::structure-access))
(inline-possible fname)
;;; Structure hack.
@@ -1171,7 +1200,9 @@
)
((eq fname 'si:|#,|)
(cmperr "Sharp-comma-macro was found in a bad place."))
- (t (let* ((info (make-info :type '*
+ (t (let* ((info (make-info :type (if (eq (second *current-form*)
fname) ;FIXME must be a better way
+ (when (boundp
'*recursion-detected*) (setq *recursion-detected* t) nil)
+ '*)
:sp-change (null (get fname 'no-sp-change))))
(args (if (and (member fname '(funcall apply))
(consp (car args))
@@ -1492,10 +1523,10 @@
;; We can't read in long-floats which are too big:
(let (tem x)
(unless (setq tem (cadr (assoc val *objects*)))
- (cond ((or
- (and (= val (symbol-value '+inf)) (c1expr `(si::|#,|
symbol-value '+inf)))
- (and (= val (symbol-value '-inf)) (c1expr `(si::|#,|
symbol-value '-inf)))
- (and (not (isfinite val)) (c1expr `(si::|#,| symbol-value
'nan)))
+ (cond ((or ;FIXME this is really grotesque
+ (and (= val (symbol-value '+inf)) (let ((l (make-list 3)))
(setf (car l) 'si::|#,| (cadr l) 'symbol-value (caddr l) ''+inf) (c1expr l)))
+ (and (= val (symbol-value '-inf)) (let ((l (make-list 3)))
(setf (car l) 'si::|#,| (cadr l) 'symbol-value (caddr l) ''-inf) (c1expr l)))
+ (and (not (isfinite val)) (let ((l (make-list 3))) (setf (car
l) 'si::|#,| (cadr l) 'symbol-value (caddr l) ''nan) (c1expr l)))
(and
(> (setq x (abs val)) (/ most-positive-long-float 2))
(c1expr `(si::|#,| * ,(/ val most-positive-long-float)
@@ -1522,6 +1553,7 @@
(t nil)))
(defmacro si::define-compiler-macro (name vl &rest body)
+ (declare (optimize (safety 1)))
`(progn (si:putprop ',name
(caddr (si:defmacro* ',name ',vl ',body))
'si::compiler-macro-prop)
Index: cmpnew/gcl_cmpfun.lsp
===================================================================
RCS file: /cvsroot/gcl/gcl/cmpnew/gcl_cmpfun.lsp,v
retrieving revision 1.29
retrieving revision 1.30
diff -u -b -r1.29 -r1.30
--- cmpnew/gcl_cmpfun.lsp 16 May 2006 16:39:51 -0000 1.29
+++ cmpnew/gcl_cmpfun.lsp 5 Jun 2006 22:02:45 -0000 1.30
@@ -999,20 +999,21 @@
)
(let ((*space* 10))
(c1expr
- `(let* ((.val ,(car args))
- (.v ,(second args))
- (.i (fill-pointer .v))
- (.dim (array-total-size .v)))
- (declare (fixnum .i .dim))
- (declare (type ,(result-type (second args)) .v))
- (declare (type ,(result-type (car args)) .val))
- (cond ((< .i .dim)
- (the fixnum (si::fill-pointer-set .v (the fixnum (+ 1 .i))))
- (si::aset .v .i .val)
- .i)
+ (let ((val (gensym)) (v (gensym)) (i (gensym)) (dim (gensym)))
+ `(let* ((,val ,(car args))
+ (,v ,(second args))
+ (,i (fill-pointer ,v))
+ (,dim (array-total-size ,v)))
+ (declare (fixnum ,i ,dim))
+ (declare (type ,(result-type (second args)) ,v))
+ (declare (type ,(result-type (car args)) ,val))
+ (cond ((< ,i ,dim)
+ (the fixnum (si::fill-pointer-set ,v (the fixnum (+ 1 ,i))))
+ (si::aset ,v ,i ,val)
+ ,i)
(t ,(cond ((eq f 'vector-push-extend)
- `(vector-push-extend .val
- .v ,@(cddr args)))))))))))
+ `(vector-push-extend ,val
+ ,v ,@(cddr args))))))))))))
(defun constant-fold-p (x)
(cond ((constantp x) t)
Index: cmpnew/gcl_cmpinline.lsp
===================================================================
RCS file: /cvsroot/gcl/gcl/cmpnew/gcl_cmpinline.lsp,v
retrieving revision 1.40
retrieving revision 1.41
diff -u -b -r1.40 -r1.41
--- cmpnew/gcl_cmpinline.lsp 16 May 2006 16:42:16 -0000 1.40
+++ cmpnew/gcl_cmpinline.lsp 5 Jun 2006 22:02:45 -0000 1.41
@@ -44,10 +44,18 @@
(import 'si::eql-is-eq-tp 'compiler)
(import 'si::equal-is-eq-tp 'compiler)
(import 'si::equalp-is-eq-tp 'compiler)
+(import 'si::is-eq-test-item-list 'compiler)
+(import 'si::cmp-vec-length 'compiler)
+(import 'si::proclaim-from-argd 'compiler)
(let ((p (find-package "DEFPACKAGE")))
(when p
(import (find-symbol "DEFPACKAGE" p) 'compiler)))
+(defmacro is-setf-function (name)
+ `(and (consp ,name) (eq (car ,name) 'setf)
+ (consp (cdr ,name)) (symbolp (cadr ,name))
+ (null (cddr ,name))))
+
;;; Pass 1 generates the internal form
;;; ( id info-object . rest )
;;; for each form encountered.
@@ -57,7 +65,6 @@
;;; are large, as occurs at present in running the random-int-form tester.
;;; 20040320 CM
-
(defmacro mia (x y) `(make-array ,x :adjustable t :fill-pointer ,y))
(defmacro eql-not-nil (x y) `(and ,x (eql ,x ,y)))
@@ -812,7 +819,7 @@
(or (cdr (assoc (cadr a) *c-vars*))
(car (rassoc (cadr a) *c-vars*)))))))
-;(setf (symbol-function 'cmp-aref) (symbol-function 'row-major-aref))
+(setf (symbol-function 'cmp-aref) (symbol-function 'row-major-aref))
(defmacro wt-bv-index (a i)
`(wt "(((" ,a ")->bv.bv_offset) + " ,i ")"))
@@ -845,7 +852,7 @@
(wt "fLrow_major_aref(" a "," i ")")))))
-;(setf (symbol-function 'cmp-aset) (symbol-function 'si::aset1))
+(setf (symbol-function 'cmp-aset) (symbol-function 'si::aset1))
(defun cmp-aset-inline-types (&rest r)
(let ((art (car r)))
Index: cmpnew/gcl_cmplet.lsp
===================================================================
RCS file: /cvsroot/gcl/gcl/cmpnew/gcl_cmplet.lsp,v
retrieving revision 1.24
retrieving revision 1.25
diff -u -b -r1.24 -r1.25
--- cmpnew/gcl_cmplet.lsp 16 May 2006 16:43:01 -0000 1.24
+++ cmpnew/gcl_cmplet.lsp 5 Jun 2006 22:02:45 -0000 1.25
@@ -104,17 +104,6 @@
; (var-is-declared var (cdr form))))
; (t nil)))
-(defun t-to-nil (x)
- (if (eq x t) nil x))
-
-(defun nil-to-t (x)
- (if x x t))
-
-(defun coerce-to-one-value (type)
- (if (and (consp type) (eq (car type) 'values))
- (cadr type)
- type))
-
(defun type-of-form (form)
(t-to-nil (coerce-to-one-value (info-type (cadr (c1expr form))))))
@@ -224,6 +213,7 @@
(defun set-var-init-type (v t1);;FIXME should be in c1make-var
(when (eq (var-kind v) 'lexical)
+ (setq t1 (coerce-to-one-value t1))
(setf (var-dt v) (var-type v)
(var-type v) t1
(var-mt v) (var-type v)
Index: cmpnew/gcl_cmpmain.lsp
===================================================================
RCS file: /cvsroot/gcl/gcl/cmpnew/gcl_cmpmain.lsp,v
retrieving revision 1.47
retrieving revision 1.48
diff -u -b -r1.47 -r1.48
--- cmpnew/gcl_cmpmain.lsp 16 May 2006 16:38:45 -0000 1.47
+++ cmpnew/gcl_cmpmain.lsp 5 Jun 2006 22:02:45 -0000 1.48
@@ -445,6 +445,7 @@
(defun compile (name &optional def &aux tem gaz (*default-pathname-defaults*
#"."))
(when (eq name 'cmp-anon)
+ (remhash name si::*call-hash-table*)
(dolist (l '(proclaimed-function proclaimed-arg-types
proclaimed-return-type))
(remprop name l)))
@@ -490,6 +491,7 @@
(eq (car name) 'lambda))
(dolist (l '(proclaimed-function proclaimed-return-type
proclaimed-arg-types))
(remprop 'cmp-anon l))
+ (remhash 'cmp-anon si::*call-hash-table*)
(eval `(defun cmp-anon ,@ (cdr name)))
(disassemble 'cmp-anon asm))
((not(symbolp name)) (princ "Not a lambda or a name") nil)
Index: cmpnew/gcl_cmpmulti.lsp
===================================================================
RCS file: /cvsroot/gcl/gcl/cmpnew/gcl_cmpmulti.lsp,v
retrieving revision 1.19
retrieving revision 1.20
diff -u -b -r1.19 -r1.20
--- cmpnew/gcl_cmpmulti.lsp 21 Mar 2006 22:33:11 -0000 1.19
+++ cmpnew/gcl_cmpmulti.lsp 5 Jun 2006 22:02:45 -0000 1.20
@@ -122,9 +122,9 @@
;;the compiler put in unnecessary code
;;if we just had say (values nil)
;; so if we know there's one value only:
- (c1expr (car args)))
+ (c1expr (let ((s (gensym))) `(let ((,s ,(car args))) ,s))))
(t (setq args (c1args args info))
- (setf (info-type info) (cons 'values (mapcar (lambda (x)
(info-type (cadr x))) args)))
+ (setf (info-type info) (cons 'values (mapcar (lambda (x)
(coerce-to-one-value (info-type (cadr x)))) args)))
(list 'values info args))))
(defun c2values (forms &aux (base *vs*) (*vs* *vs*))
Index: cmpnew/gcl_cmpopt.lsp
===================================================================
RCS file: /cvsroot/gcl/gcl/cmpnew/gcl_cmpopt.lsp,v
retrieving revision 1.32
retrieving revision 1.33
diff -u -b -r1.32 -r1.33
--- cmpnew/gcl_cmpopt.lsp 31 Mar 2006 21:59:38 -0000 1.32
+++ cmpnew/gcl_cmpopt.lsp 5 Jun 2006 22:02:45 -0000 1.33
@@ -199,8 +199,10 @@
(get 'system:elt-set 'inline-unsafe))
;;SYSTEM:FILL-POINTER-SET
- (push '((t fixnum) fixnum #.(flags rfa
set)"(((#0)->st.st_fillp)=(((#0)->st.st_hasfillp) ? (#1) :
((#0)->st.st_fillp)))")
+ (push '((t fixnum) seqind #.(flags rfa
set)"(((#0)->st.st_fillp)=(((#0)->st.st_hasfillp) ? (#1) :
((#0)->st.st_fillp)))")
(get 'system:fill-pointer-set 'inline-unsafe))
+ (push '(((vector) seqind) seqind #.(flags rfa
set)"(((#0)->st.st_fillp)=(((#0)->st.st_hasfillp) ? (#1) :
((#0)->st.st_fillp)))")
+ (get 'system:fill-pointer-set 'inline-always))
;;SYSTEM:FIXNUMP
(push '((t) boolean #.(flags rfa)"type_of(#0)==t_fixnum")
Index: cmpnew/gcl_cmpspecial.lsp
===================================================================
RCS file: /cvsroot/gcl/gcl/cmpnew/gcl_cmpspecial.lsp,v
retrieving revision 1.12
retrieving revision 1.13
diff -u -b -r1.12 -r1.13
--- cmpnew/gcl_cmpspecial.lsp 16 May 2006 16:41:23 -0000 1.12
+++ cmpnew/gcl_cmpspecial.lsp 5 Jun 2006 22:02:45 -0000 1.13
@@ -50,7 +50,7 @@
(defun c1declare (args)
(cmperr "The declaration ~s was found in a bad place." (cons 'declare args)))
-(defconstant +useful-c-types+ '(fixnum short-float long-float proper-list t))
+(defconstant +useful-c-types+ '(seqind fixnum short-float long-float
proper-list t))
(defun c1the (args &aux info form type dtype)
(when (or (endp args) (endp (cdr args)))
@@ -74,7 +74,8 @@
(setf (var-mt v) nmt))
(throw (var-tag v) v)))))
(setq type (type-filter (car args)))
- (cmpwarn "Type mismatch was found in ~s.~%Modifying type ~s to ~s." (cons
'the args) (info-type info) type))
+ (unless (not (and dtype (info-type info)))
+ (cmpwarn "Type mismatch was found in ~s.~%Modifying type ~s to ~s."
(cons 'the args) (info-type info) type)))
(setq form (list* (car form) info (cddr form)))
(if (type>= 'boolean (car args)) (setf (info-type (cadr form)) type)
(set-form-type form type))
Index: cmpnew/gcl_cmptop.lsp
===================================================================
RCS file: /cvsroot/gcl/gcl/cmpnew/gcl_cmptop.lsp,v
retrieving revision 1.34
retrieving revision 1.35
diff -u -b -r1.34 -r1.35
--- cmpnew/gcl_cmptop.lsp 16 May 2006 16:38:45 -0000 1.34
+++ cmpnew/gcl_cmptop.lsp 5 Jun 2006 22:02:45 -0000 1.35
@@ -432,7 +432,8 @@
(and (consp *eval-when-defaults*)
(or (member 'compile *eval-when-defaults* )
(member :compile-toplevel *eval-when-defaults* ))))
- (if form (cmp-eval form))
+ (when form
+ (cmp-eval form))
t)))
@@ -448,8 +449,7 @@
(let ((*eval-when-defaults* (car args)))
(when load-flag
(t1progn (cdr args)))
- (when compile-flag
- (cmp-eval (cons 'progn (cdr args))))))
+ (when compile-flag (cmp-eval (cons 'progn (cdr args))))))
(defvar *compile-ordinaries* nil)
@@ -483,7 +483,7 @@
(error "~S not a symbol" sym))
(or
(setf-function-proxy-symbol sym)
- (let ((new (gensym))
+ (let ((new (intern (symbol-name (gensym (concatenate 'string (symbol-name
sym) "-SETF"))) (symbol-package sym)));FIXME not necessary
(prop (get sym 'setf-proclamations)))
(push (cons sym new) *setf-function-proxy-symbols*)
(when prop
@@ -493,11 +493,6 @@
(si::putprop new (cdr prop) l)))))
new)))
-(defmacro is-setf-function (name)
- `(and (consp ,name) (eq (car ,name) 'setf)
- (consp (cdr ,name)) (symbolp (cadr ,name))
- (null (cddr ,name))))
-
(defun function-symbol (name)
(cond
((symbolp name)
@@ -516,6 +511,62 @@
(symbol-name name))))
(defvar *compiler-auto-proclaim* t)
+(defvar *mlts* nil)
+
+(defmacro ndbctxt (&rest body)
+ `(let ((*debug* *debug*)
+ (*compiler-check-args* *compiler-check-args*)
+ (*safe-compile* *safe-compile*)
+ (*compiler-push-events* *compiler-push-events*)
+ (*notinline* *notinline*)
+ (*space* *space*))
+ ,@body))
+
+(defun portable-source (form &optional cdr)
+ (cond ((atom form) form)
+ (cdr (cons (portable-source (car form)) (portable-source (cdr form) t)))
+ ((case (car form)
+ ((let let* lambda)
+ `(,(car form)
+ ,(mapcar (lambda (x) (if (atom x) x `(,(car x)
,@(portable-source (cdr x) t)))) (cadr form))
+ ,@(let ((r (remove-if-not 'si::specialp (mapcar (lambda (x)
(if (atom x) x (car x))) (cadr form)))))
+ (when r `((declare (special ,@r)))))
+ ,@(ndbctxt (portable-source (cddr form) t))))
+ ((quote function) form)
+ (declare
+ (let ((opts (mapcan 'cdr
+ (remove-if-not
+ (lambda (x) (and (consp x) (eq (car x)
'optimize)))
+ (cdr form)))))
+ (when opts (local-compile-decls opts)))
+ form)
+ (the `(,(car form) ,(cadr form) ,@(portable-source (cddr form)
t)))
+ ((flet labels macrolet)
+ `(,(car form)
+ ,(mapcar (lambda (x) `(,(car x) ,@(cdr (portable-source
`(lambda ,@(cdr x)))))) (cadr form))
+ ,@(let ((*mlts* *mlts*))
+ (when (eq (car form) 'macrolet)
+ (dolist (l (cadr form)) (push (car l) *mlts*)))
+ (ndbctxt (portable-source (cddr form) t)))))
+ (multiple-value-bind `(,(car form) ,(cadr form)
,(portable-source (caddr form))
+ ,@(let ((r (remove-if-not 'si::specialp
(cadr form))))
+ (when r `((declare (special ,@r)))))
+ ,@(ndbctxt (portable-source (cdddr form)
t))))))
+ ((let* ((fd (and (symbolp (car form)) (not (member (car form) *mlts*))
+ (or (get (car form) 'si::compiler-macro-prop)
(macro-function (car form)))))
+ (nf (if fd (cmp-expand-macro fd (car form) (cdr form)) form)))
+ (portable-source nf (equal form nf))))))
+
+(defun pd (form)
+ (portable-source form))
+
+;FIXME should be able to carry a full type here.
+(defun sanitize-tp (tp)
+ (cond ((and (consp tp) (eq (car tp) 'values) (not (cddr tp))) (cadr
tp))
+ ((or (eq tp '*) (and (consp tp) (member (car tp) '(* values)))) '*)
+ ((car (member tp +useful-c-types+ :test 'type<=)))));FIXME recursion
+
+(defvar *recursion-detected*)
(defun t1defun (args &aux (setjmps *setjmps*) (defun 'defun) (*sharp-commas*
nil) fname lambda-expr cfun doc)
(when (or (endp args) (endp (cdr args)))
@@ -528,30 +579,43 @@
top
(setq *non-package-operation* t)
(setq *local-functions* nil)
+
+ (let ((*recursion-detected* nil))
+
(let* ((*vars* nil) (*funs* nil) (*blocks* nil) (*tags* nil)
(*special-binding* nil))
-; (let ((args (car (recursively-cmp-macroexpand (list (cons 'lambda (cdr
args))) nil))))
-; (setq lambda-expr (c1lambda-expr (cdr args) fname)))
(setq lambda-expr (c1lambda-expr (cdr args) fname)))
(or (eql setjmps *setjmps*) (setf (info-volatile (cadr lambda-expr)) t))
(check-downward (cadr lambda-expr))
(when *compiler-auto-proclaim*
- (let* ((al (mapcar 'var-type (caaddr lambda-expr)))
- (rt (info-type (cadar (last lambda-expr))));FIXME
- (rt (if (and (consp rt) (eq 'values (car rt))) '* rt)))
+
+ (let* ((al (mapcar (lambda (x) (sanitize-tp (var-type x))) (caaddr
lambda-expr)))
+ (rt (sanitize-tp (info-type (cadar (last lambda-expr))))))
+
(when (notevery 'null (cdaddr lambda-expr)) (if al (nconc al '(*)) (setq
al '(*))))
+
(cmpnote "(proclaim '(ftype (function ~s ~s) ~s~%" al rt fname)
- (let ((oal (get fname 'proclaimed-arg-types)))
+
+ (let ((oal (get fname 'proclaimed-arg-types))
+ (ort (get fname 'proclaimed-return-type)))
(when oal
(unless (and (= (length al) (length oal))
(every (lambda (x y) (or (and (eq x '*) (eq y '*))
(type>= y x))) al oal))
- (cmpwarn "arg type mismatch in auto-proclamation ~s -> ~s~%" oal
al))))
- (let ((ort (get fname 'proclaimed-return-type)))
+ (cmpwarn "arg type mismatch in auto-proclamation ~s -> ~s~%" oal
al)
+ ))
(when ort
(unless (or (and (eq rt '*) (or (eq ort '*) (equal ort '(*))))
(type>= ort rt))
- (cmpwarn "ret type mismatch in auto-proclamation ~s -> ~s~%" ort
rt))))
- (proclaim `(ftype (function ,al ,rt) ,fname))))
+ ;(cmpwarn "ret type mismatch in auto-proclamation ~s -> ~s~%" ort
rt)
+ ))
+ (proclaim `(ftype (function ,al ,rt) ,fname));FIXME replace proclaim
+ (si::add-hash fname (let* ((at (get fname 'proclaimed-arg-types))
+ (rt (get fname 'proclaimed-return-type))
+ (rt (if (equal '(*) rt) '* rt)))
+ (when (or at rt) (list at rt))) nil nil)
+ (when *recursion-detected*;FIXME
+ (unless (and (equal oal (get fname 'proclaimed-arg-types)) (equal
ort (get fname 'proclaimed-return-type)))
+ (go top)))))))
;;provide a simple way for the user to declare functions to
@@ -636,9 +700,18 @@
(push (list defun fname cfun lambda-expr doc *special-binding*)
*top-level-forms*)
(push (cons fname cfun) *global-funs*)
-
-
- ))
+ (let (decls doc (ll (cadr args)) (args (cddr args)))
+ (when (and (consp args) (stringp (car args))) (push (pop args) doc))
+ (do nil ((or (not args) (not (consp (car args))) (not (eq (caar args)
'declare))))
+ (push (pop args) decls))
+ (push (cons fname (pd `(lambda ,ll
+ ,@doc
+ (declare (optimize (safety ,(cond
(*compiler-push-events* 3)
+
(*safe-compile* 2)
+
(*compiler-check-args* 1)
+ (0)))))
+ ,@(nreverse decls)
+ (block ,fname ,@args)))) *portable-source*))))
(defun make-inline-string (cfun args fname)
(if (null args)
@@ -671,16 +744,6 @@
(let ((x (position x +c-global-arg-types+)))
(if x (1+ x) 0))))
-(defun is-global-arg-type (x)
- (let ((x (promoted-c-type x)))
- (or (eq x t) (member x +c-global-arg-types+))))
-(defun is-local-arg-type (x)
- (let ((x (promoted-c-type x)))
- (or (eq x t) (member x +c-local-arg-types+))))
-(defun is-local-var-type (x)
- (let ((x (promoted-c-type x)))
- (or (eq x t) (member x +c-local-var-types+))))
-
(defun proclaimed-argd (args return)
(let ((ans (length args))
(i 8)
@@ -698,6 +761,20 @@
(setq i (the fixnum (+ i 2)))
(setq type (f-type (pop args))))))
+(defun type-f (x)
+ (declare (fixnum x))
+ (if (zerop x) t (nth (1- x) +c-global-arg-types+)))
+
+;FIXME obsolete
+(defun proclaim-from-argd (argd)
+ (declare (fixnum argd))
+ (let* ((n (logand argd (1- (ash 1 8))))
+ (argd (ash argd -8))
+ (ret (logand argd (1- (ash 1 2))))
+ (argd (ash argd -4))
+ (args (let (r) (dotimes (i n) (push (logand argd (1- (ash 1 2))) r)
(setq argd (ash argd -2))) (nreverse r))))
+ (list (mapcar 'type-f args) (type-f ret))))
+
(defun wt-if-proclaimed (fname cfun lambda-expr)
(cond ((fast-link-proclaimed-type-p fname)
@@ -771,6 +848,15 @@
(push (list a) *vaddress-list*)
(prog1 *vind* (incf *vind*)))
+;FIXME obsolete
+(defun collect-objects (le)
+ (cond ((atom le) nil)
+ ((and (eq (car le) 'location) (consp (caddr le)) (eq (caaddr le) 'vv))
+ (list (or (car (member (cadr (caddr le)) *top-level-forms* :key 'cadr))
+ (aref (data-vector) (cadr (caddr le))))))
+ ((append (collect-objects (car le)) (collect-objects (cdr le))))))
+
+
(defun t2defun (fname cfun lambda-expr doc sp)
(declare (ignore sp))
(cond ((get fname 'no-global-entry)(return-from t2defun nil)))
@@ -798,9 +884,24 @@
(t (wt-h cfun "();")
(add-init `(si::mf ',fname ,(add-address (c-function-name "" cfun
fname) )) )))
+ (let ((h (gethash fname si::*call-hash-table*)))
+ (add-init `(si::add-hash ',fname ',(si::call-sig h)
+ ',(mapcar (lambda (x)
+ (cons x (let ((y (find fname
si::*needs-recompile* :key 'car)))
+ (unless (and y (eq (cadr y) x))
+ (si::call-sig (gethash x
si::*call-hash-table*))))))
+ (sublis +cmp-fn-alist+ (si::call-callees h)))
+ ,(let* ((w (make-string-output-stream))
+ (ss (si::open-fasd w :output nil nil))
+ (out (cdr (assoc fname *portable-source*))))
+ (si::find-sharing-top out (aref ss 1))
+ (si::write-fasd-top out ss)
+ (si::close-fasd ss)
+ (get-output-stream-string w)))))
+
(let ((base-name (setf-function-base-symbol fname)))
(when base-name
- (add-init `(si::putprop ',base-name #',fname 'si::setf-function))))
+ (add-init `(si::putprop ',base-name ',fname 'si::setf-function))))
(cond ((< *space* 2)
(setf (get fname 'debug-prop) t)
Index: cmpnew/gcl_cmptype.lsp
===================================================================
RCS file: /cvsroot/gcl/gcl/cmpnew/gcl_cmptype.lsp,v
retrieving revision 1.32
retrieving revision 1.33
diff -u -b -r1.32 -r1.33
--- cmpnew/gcl_cmptype.lsp 16 May 2006 16:39:51 -0000 1.32
+++ cmpnew/gcl_cmptype.lsp 5 Jun 2006 22:02:45 -0000 1.33
@@ -405,9 +405,15 @@
(dolist (l '(/ floor ceiling truncate round ffloor fceiling ftruncate fround))
(si::putprop l t 'zero-pole))
-(dolist (l '(+ - * exp float sqrt atan min max))
+(dolist (l '(+ - * exp float sqrt atan))
(si::putprop l 'super-range 'type-propagator))
+(defun min-max-propagator (f &optional (t1 nil t1p) (t2 nil t2p))
+ (cond (t2p (super-range f t1 t2))
+ (t1p (super-range f t1))))
+(si::putprop 'max 'min-max-propagator 'type-propagator)
+(si::putprop 'min 'min-max-propagator 'type-propagator)
+
(defun /-propagator (f t1 &optional t2)
(cond (t2 (super-range f t1 (type-and t2 '(not (real 0 0)))))
((super-range f (type-and t1 `(not (real 0 0)))))))
@@ -575,7 +581,7 @@
(defun and-form-type (type form original-form &aux type1)
(setq type1 (type-and type (info-type (cadr form))))
- (when (null type1)
+ (when (and (null type1) type (info-type (cadr form)))
(cmpwarn "The type of the form ~s is not ~s, but ~s." original-form
type (info-type (cadr form))))
(if (eq type1 (info-type (cadr form)))
form
@@ -584,7 +590,7 @@
(list* (car form) info (cddr form)))))
(defun check-form-type (type form original-form)
- (when (null (type-and type (info-type (cadr form))))
+ (when (and (null (type-and type (info-type (cadr form)))) type (info-type
(cadr form)))
(cmpwarn "The type of the form ~s is not ~s, but ~s." original-form
type (info-type (cadr form)))))
(defconstant +c1nil+ (list 'LOCATION (make-info :type (object-type nil)) nil))
Index: cmpnew/gcl_cmputil.lsp
===================================================================
RCS file: /cvsroot/gcl/gcl/cmpnew/gcl_cmputil.lsp,v
retrieving revision 1.6
retrieving revision 1.7
diff -u -b -r1.6 -r1.7
--- cmpnew/gcl_cmputil.lsp 31 Mar 2006 21:59:38 -0000 1.6
+++ cmpnew/gcl_cmputil.lsp 5 Jun 2006 22:02:45 -0000 1.7
@@ -262,20 +262,20 @@
(defun compiler-def-hook (symbol code) symbol code nil)
-(defun compiler-clear-compiler-properties (symbol code)
- code
- (let ((v (symbol-plist symbol)) w)
- (tagbody
- top
- (setq w (car v))
- (cond ((and (symbolp w)
- (get w 'compiler-prop))
+;; (defun compiler-clear-compiler-properties (symbol code)
+;; code
+;; (let ((v (symbol-plist symbol)) w)
+;; (tagbody
+;; top
+;; (setq w (car v))
+;; (cond ((and (symbolp w)
+;; (get w 'compiler-prop))
- (setq v (cddr v))
- (remprop symbol w))
- (t (setq v (cddr v))))
- (or (null v) (go top)))
- (compiler-def-hook symbol code)
- ))
+;; (setq v (cddr v))
+;; (remprop symbol w))
+;; (t (setq v (cddr v))))
+;; (or (null v) (go top)))
+;; (compiler-def-hook symbol code)
+;; ))
;hi
Index: cmpnew/gcl_cmpvar.lsp
===================================================================
RCS file: /cvsroot/gcl/gcl/cmpnew/gcl_cmpvar.lsp,v
retrieving revision 1.16
retrieving revision 1.17
diff -u -b -r1.16 -r1.17
--- cmpnew/gcl_cmpvar.lsp 16 May 2006 16:41:23 -0000 1.16
+++ cmpnew/gcl_cmpvar.lsp 5 Jun 2006 22:02:45 -0000 1.17
@@ -349,8 +349,9 @@
(defun do-setq-tp (v form t1)
(when (eq (var-kind v) 'lexical)
+ (setq t1 (coerce-to-one-value t1))
(let* ((tp (type-and (var-dt v) t1)))
- (unless tp
+ (unless (or tp (not (and (var-dt v) t1)))
(cmpwarn "Type mismatches between ~s/~s and ~s/~s." (var-name v)
(var-dt v) form t1))
(when (boundp '*restore-vars*)
(unless (member v *restore-vars* :key 'car)
@@ -367,7 +368,7 @@
(defun set-form-type (form type)
(let* ((it (info-type (cadr form)))
(nt (type-and type it)))
- (unless nt
+ (unless (or nt (not (and type it)))
(cmpwarn "Type mismatch: ~s ~s~%" it type))
(setf (info-type (cadr form)) nt)
(case (car form)
Index: cmpnew/gcl_cmpwt.lsp
===================================================================
RCS file: /cvsroot/gcl/gcl/cmpnew/gcl_cmpwt.lsp,v
retrieving revision 1.5
retrieving revision 1.6
diff -u -b -r1.5 -r1.6
--- cmpnew/gcl_cmpwt.lsp 23 Jul 2005 08:49:16 -0000 1.5
+++ cmpnew/gcl_cmpwt.lsp 5 Jun 2006 22:02:45 -0000 1.6
@@ -22,8 +22,86 @@
(in-package 'compiler)
+(defstruct (fasd (:type vector))
+ stream
+ table
+ eof
+ direction
+ package
+ index
+ filepos
+ table_length
+ evald_forms ; list of forms eval'd. (load-time-eval)
+ )
+
+(defvar *fasd-ops*
+'( d_nil ;/* dnil: nil */
+ d_eval_skip ; /* deval o1: evaluate o1 after reading it */
+ d_delimiter ;/* occurs after d_listd_general and d_new_indexed_items */
+ d_enter_vector ; /* d_enter_vector o1 o2 .. on d_delimiter make a
cf_data with
+ ; this length. Used internally by gcl. Just make
+ ; an array in other lisps */
+ d_cons ; /* d_cons o1 o2: (o1 . o2) */
+ d_dot ;
+ d_list ;/* list* delimited by d_delimiter d_list,o1,o2, ... ,d_dot,on
+ ;for (o1 o2 . on)
+ ;or d_list,o1,o2, ... ,on,d_delimiter for (o1 o2 ... on)
+ ;*/
+ d_list1 ;/* nil terminated length 1 d_list1o1 */
+ d_list2 ; /* nil terminated length 2 */
+ d_list3
+ d_list4
+ d_eval
+ d_short_symbol
+ d_short_string
+ d_short_fixnum
+ d_short_symbol_and_package
+ d_bignum
+ d_fixnum
+ d_string
+ d_objnull
+ d_structure
+ d_package
+ d_symbol
+ d_symbol_and_package
+ d_end_of_file
+ d_standard_character
+ d_vector
+ d_array
+ d_begin_dump
+ d_general_type
+ d_sharp_equals ; /* define a sharp */
+ d_sharp_value
+ d_sharp_value2
+ d_new_indexed_item
+ d_new_indexed_items
+ d_reset_index
+ d_macro
+ d_reserve1
+ d_reserve2
+ d_reserve3
+ d_reserve4
+ d_indexed_item3 ; /* d_indexed_item3 followed by 3bytes to give index */
+ d_indexed_item2 ; /* d_indexed_item2 followed by 2bytes to give index
*/
+ d_indexed_item1
+ d_indexed_item0 ; /* This must occur last ! */
+))
+
+;(require 'FASDMACROS "../cmpnew/gcl_fasdmacros.lsp")
(eval-when (compile eval)
- (require 'FASDMACROS "../cmpnew/gcl_fasdmacros.lsp")
+; (require 'FASDMACROS "../cmpnew/gcl_fasdmacros.lsp")
+
+(defmacro put-op (op str)
+ `(write-byte ,(or (position op *fasd-ops*)
+ (error "illegal op")) ,str))
+
+(defmacro put2 (n str)
+ `(progn (write-bytei ,n 0 ,str)
+ (write-bytei ,n 1 ,str)))
+
+(defmacro write-bytei (n i str)
+ `(write-byte (the fixnum (ash (the fixnum ,n) >> ,(* i 8))) ,str))
+
(defmacro data-vector () `(car *data*))
@@ -113,8 +191,11 @@
(verify-data-vector (data-vector))
(let* ((vec (coerce (nreverse (data-inits)) 'vector)))
(verify-data-vector vec)
- (setf (aref (data-vector) (- (length (data-vector)) 1))
- (cons 'si::%init vec))
+ (let ((v (make-array 2)))
+ (setf (aref v 0) `(let ((si::*disable-recompile* t)) ,@(coerce vec
'list))
+ (aref v 1) `(si::do-recompile)
+ (aref (data-vector) (- (length (data-vector)) 1))
+ (cons 'si::%init v)))
(setf (data-package-ops) (nreverse (data-package-ops)))
(cond (*fasd-data*
(wt-fasd-data-file))
Index: cmpnew/gcl_fasdmacros.lsp
===================================================================
RCS file: /cvsroot/gcl/gcl/cmpnew/gcl_fasdmacros.lsp,v
retrieving revision 1.3
retrieving revision 1.4
diff -u -b -r1.3 -r1.4
--- cmpnew/gcl_fasdmacros.lsp 23 Jul 2005 08:49:24 -0000 1.3
+++ cmpnew/gcl_fasdmacros.lsp 5 Jun 2006 22:02:45 -0000 1.4
@@ -1,6 +1,6 @@
;; -*-Lisp-*-
-
+(in-package 'compiler)
(defstruct (fasd (:type vector))
stream
table
Index: cmpnew/gcl_lfun_list.lsp
===================================================================
RCS file: /cvsroot/gcl/gcl/cmpnew/gcl_lfun_list.lsp,v
retrieving revision 1.10
retrieving revision 1.11
diff -u -b -r1.10 -r1.11
--- cmpnew/gcl_lfun_list.lsp 31 Mar 2006 21:59:38 -0000 1.10
+++ cmpnew/gcl_lfun_list.lsp 5 Jun 2006 22:02:45 -0000 1.11
@@ -207,7 +207,7 @@
(DEFSYSFUN 'CDDADR "Lcddadr" '(T) 'T NIL NIL)
(DEFSYSFUN 'CDADDR "Lcdaddr" '(T) 'T NIL NIL)
(DEFSYSFUN 'CADDDR "Lcadddr" '(T) 'T NIL NIL)
-(DEFSYSFUN 'FILL-POINTER "Lfill_pointer" '(T) 'FIXNUM NIL NIL)
+(DEFSYSFUN 'FILL-POINTER "Lfill_pointer" '(T) 'SEQIND NIL NIL)
(DEFSYSFUN 'MAPCAR "Lmapcar" '(T T *) 'T NIL NIL)
(DEFSYSFUN 'FLOATP "Lfloatp" '(T) 'T NIL T)
(DEFSYSFUN 'SHADOW "Lshadow" '(T *) 'T NIL NIL)
@@ -432,7 +432,7 @@
(DEFSYSFUN 'SYSTEM::SVSET "siLsvset" '(SIMPLE-VECTOR FIXNUM T) T NIL
NIL)
(DEFSYSFUN 'SYSTEM::FILL-POINTER-SET "siLfill_pointer_set"
- '(VECTOR FIXNUM) 'FIXNUM NIL NIL)
+ '(VECTOR FIXNUM) 'SEQIND NIL NIL)
(DEFSYSFUN 'SYSTEM::REPLACE-ARRAY "siLreplace_array" NIL T NIL NIL)
(DEFSYSFUN 'SYSTEM::FSET "siLfset" '(SYMBOL T) NIL NIL NIL)
(DEFSYSFUN 'SYSTEM::HASH-SET "siLhash_set" NIL T NIL NIL)
Index: lsp/gcl_arraylib.lsp
===================================================================
RCS file: /cvsroot/gcl/gcl/lsp/gcl_arraylib.lsp,v
retrieving revision 1.10
retrieving revision 1.11
diff -u -b -r1.10 -r1.11
--- lsp/gcl_arraylib.lsp 18 Sep 2005 02:08:49 -0000 1.10
+++ lsp/gcl_arraylib.lsp 5 Jun 2006 22:02:45 -0000 1.11
@@ -244,12 +244,12 @@
(defun vector-pop (vector)
+ (check-type vector vector)
(let ((fp (fill-pointer vector)))
- (declare (fixnum fp))
(when (= fp 0)
(error "The fill pointer of the vector ~S zero." vector))
- (si:fill-pointer-set vector (the fixnum (1- fp)))
- (aref vector (the fixnum (1- fp)))))
+ (fill-pointer-set vector (1- fp))
+ (aref vector (1- fp))))
(defun adjust-array (array new-dimensions
Index: lsp/gcl_defmacro.lsp
===================================================================
RCS file: /cvsroot/gcl/gcl/lsp/gcl_defmacro.lsp,v
retrieving revision 1.6
retrieving revision 1.7
diff -u -b -r1.6 -r1.7
--- lsp/gcl_defmacro.lsp 27 Nov 2005 18:08:33 -0000 1.6
+++ lsp/gcl_defmacro.lsp 5 Jun 2006 22:02:45 -0000 1.7
@@ -83,6 +83,7 @@
&aux *dl* (*key-check* nil)
(*arg-check* nil)
doc decls whole ppn (env nil) envp)
+ (declare (ignore name))
(cond ((listp vl))
((symbolp vl) (setq vl (list '&rest vl)))
(t (error "The defmacro-lambda-list ~s is not a list." vl)))
@@ -107,9 +108,10 @@
(dolist (ac *arg-check*)
(push `(unless (endp ,(dm-nth-cdr (cdr ac) (car ac)))
(dm-too-many-arguments)) body))
- (unless envp (push `(declare (ignore ,env)) body))
- (list doc ppn `(lambda-block ,name ,(reverse *dl*) ,@(append decls body)))
- )
+ (unless envp (push `(declare (ignore ,env)) decls))
+; (list doc ppn `(lambda-block ,name ,(reverse *dl*) ,@(append decls body)))
+; (list doc ppn (eval `(lambda ,(reverse *dl*) ,@decls (block ,name ,@body))))
+ (list doc ppn (let ((nn (gensym))) (eval `(defun ,nn ,(reverse *dl*) ,@decls
(block ,name ,@body))) (symbol-function nn))))
(defun dm-vl (vl whole top)
(do ((optionalp nil) (restp nil) (keyp nil)
Index: lsp/gcl_defstruct.lsp
===================================================================
RCS file: /cvsroot/gcl/gcl/lsp/gcl_defstruct.lsp,v
retrieving revision 1.10
retrieving revision 1.11
diff -u -b -r1.10 -r1.11
--- lsp/gcl_defstruct.lsp 18 Sep 2005 02:08:49 -0000 1.10
+++ lsp/gcl_defstruct.lsp 5 Jun 2006 22:02:45 -0000 1.11
@@ -71,6 +71,7 @@
(or no-fun
(and (fboundp access-function)
(eq (aref accsrs offset) (symbol-function access-function)))
+ (progn
(setf (symbol-function access-function)
(or (aref accsrs offset)
(setf (aref accsrs offset)
@@ -87,7 +88,8 @@
((eq accsrs *vector-accessors*)
(lambda(x)
(declare (optimize (safety 1)))
- (aref x offset)))))))))
+ (aref x offset)))))))
+ (add-hash access-function `((t) ,(or (not slot-type)
slot-type)) nil nil))))
(cond (read-only
(remprop access-function 'structure-access)
(setf (get access-function 'struct-read-only) t))
@@ -416,6 +418,7 @@
(list ar (round-up pos (size-of t)) has-holes)
))))
+;FIXME function-src for all functions, sigs for constructor and copier
(defun define-structure (name conc-name no-conc type named slot-descriptions
copier
static include print-function constructors
offset predicate &optional documentation no-funs
@@ -501,11 +504,14 @@
documentation))
(when (and (null type) predicate)
(record-fn predicate 'defun '(t) t)
+
(or no-funs
+ (progn
(setf (symbol-function predicate)
(lambda (x)
(declare (optimize (safety 1)))
- (si::structure-subtype-p x name))))
+ (si::structure-subtype-p x name)))
+ (add-hash predicate `((t) boolean) nil nil)))
(setf (get predicate 'compiler::co1)
'compiler::co1structure-predicate)
(setf (get predicate 'struct-predicate) name)
Index: lsp/gcl_evalmacros.lsp
===================================================================
RCS file: /cvsroot/gcl/gcl/lsp/gcl_evalmacros.lsp,v
retrieving revision 1.19
retrieving revision 1.20
diff -u -b -r1.19 -r1.20
--- lsp/gcl_evalmacros.lsp 16 May 2006 16:44:59 -0000 1.19
+++ lsp/gcl_evalmacros.lsp 5 Jun 2006 22:02:45 -0000 1.20
@@ -29,7 +29,7 @@
(eval-when (compile) (proclaim '(optimize (safety 1) (space 3))))
-(eval-when (eval compile) (defun si:clear-compiler-properties (symbol)))
+;(eval-when (eval compile) (defun si:clear-compiler-properties (symbol code)))
(eval-when (eval compile) (setq si:*inhibit-macro-special* nil))
Index: lsp/gcl_iolib.lsp
===================================================================
RCS file: /cvsroot/gcl/gcl/lsp/gcl_iolib.lsp,v
retrieving revision 1.11
retrieving revision 1.12
diff -u -b -r1.11 -r1.12
--- lsp/gcl_iolib.lsp 16 Mar 2006 12:34:04 -0000 1.11
+++ lsp/gcl_iolib.lsp 5 Jun 2006 22:02:45 -0000 1.12
@@ -710,5 +710,7 @@
(let ((args (let ((et (cadr (member :element-type args))))
(if et `(:element-type ,(restrict-stream-element-type et)
,@args)
args))))
- (apply 'open1 f args)))
+ (values (apply 'open1 f args))))
\ No newline at end of file
+(defun load (f &rest args)
+ (values (apply 'load1 f args)))
\ No newline at end of file
Index: lsp/gcl_loadcmp.lsp
===================================================================
RCS file: /cvsroot/gcl/gcl/lsp/gcl_loadcmp.lsp,v
retrieving revision 1.3
retrieving revision 1.4
diff -u -b -r1.3 -r1.4
--- lsp/gcl_loadcmp.lsp 23 Jul 2005 08:52:00 -0000 1.3
+++ lsp/gcl_loadcmp.lsp 5 Jun 2006 22:02:45 -0000 1.4
@@ -44,5 +44,5 @@
(apply 'compiler::compile1 system::args))
(defun disassemble (&rest system::args &aux (*print-pretty* nil))
(apply 'compiler::disassemble1 system::args))
-(setf (symbol-function 'si:clear-compiler-properties)
- (symbol-function 'compiler::compiler-clear-compiler-properties))
+;(setf (symbol-function 'si:clear-compiler-properties)
+; (symbol-function 'compiler::compiler-clear-compiler-properties))
Index: lsp/gcl_mislib.lsp
===================================================================
RCS file: /cvsroot/gcl/gcl/lsp/gcl_mislib.lsp,v
retrieving revision 1.14
retrieving revision 1.15
diff -u -b -r1.14 -r1.15
--- lsp/gcl_mislib.lsp 21 Mar 2006 22:42:59 -0000 1.14
+++ lsp/gcl_mislib.lsp 5 Jun 2006 22:02:45 -0000 1.15
@@ -25,8 +25,7 @@
(export 'time)
-(export '(function-lambda-expression
- reset-sys-paths decode-universal-time
+(export '(reset-sys-paths decode-universal-time
encode-universal-time compile-file-pathname complement constantly))
@@ -130,24 +129,6 @@
(declare (optimize (safety 1)))
(lambda (&rest args) (not (apply fn args))))
-(defun default-system-banner ()
- (let (gpled-modules)
- (dolist (l '(:unexec :bfd :readline))
- (when (member l *features*)
- (push l gpled-modules)))
- (format nil "GCL (GNU Common Lisp) ~a.~a.~a ~a ~a ~a~%~a~%~a
~a~%~a~%~a~%~%~a~%"
- *gcl-major-version* *gcl-minor-version* *gcl-extra-version*
- (if (member :ansi-cl *features*) "ANSI" "CLtL1")
- (if (member :gprof *features*) "profiling" "")
- (si::gcl-compile-time)
- "Source License: LGPL(gcl,gmp,pargcl), GPL(unexec,bfd)"
- "Binary License: "
- (if gpled-modules (format nil "GPL due to GPL'ed components: ~a"
gpled-modules)
- "LGPL")
- "Modifications of this banner must retain notice of a compatible
license"
- "Dedicated to the memory of W. Schelter"
- "Use (help) to get some basic information on how to use GCL.")))
-
(defun lisp-implementation-version nil
(declare (optimize (safety 1)))
(format nil "GCL ~a.~a.~a"
@@ -173,17 +154,6 @@
(setq si::*load-path* nl))
nil)
-(defun function-lambda-expression (x)
- (if (typep x 'interpreted-function)
- (let* ((x (si::interpreted-function-lambda x)))
- (case (car x)
- (lambda (values x nil nil))
- (lambda-block (values (cons 'lambda (cddr x)) nil (cadr x)))
- (lambda-closure (values (cons 'lambda (cddr (cddr x))) (not (not
(cadr x))) nil))
- (lambda-block-closure (values (cons 'lambda (cdr (cddr (cddr
x)))) (not (not (cadr x))) (fifth x)))
- (otherwise (values nil t nil))))
- (values nil t nil)))
-
(defun heaprep nil
(let ((f (list
Index: lsp/gcl_module.lsp
===================================================================
RCS file: /cvsroot/gcl/gcl/lsp/gcl_module.lsp,v
retrieving revision 1.6
retrieving revision 1.7
diff -u -b -r1.6 -r1.7
--- lsp/gcl_module.lsp 18 Sep 2005 02:46:35 -0000 1.6
+++ lsp/gcl_module.lsp 5 Jun 2006 22:02:45 -0000 1.7
@@ -58,22 +58,37 @@
(load (car p)))))))
-(defun documentation (symbol doc-type)
- (case doc-type
- (variable (get symbol 'variable-documentation))
- (function (get symbol 'function-documentation))
- (structure (get symbol 'structure-documentation))
- (type (get symbol 'type-documentation))
- (setf (get symbol 'setf-documentation))
- (compiler-macro (get symbol 'compiler-macro-documentation))
- (method-combination (get symbol 'method-combination-documentation))
- (otherwise
- (cond
- ((packagep symbol)
- (get (find-symbol (package-name symbol) :keyword)
'package-documentation))
- ((eql doc-type t) nil)
- (t (error "~S is an illegal documentation type." doc-type))))))
+(defun documentation (object doc-type)
+ (cond ((typep object 'function)
+ (setq object (function-name object)))
+ ((typep object 'package)
+ (setq object (find-symbol (package-name object) :keyword))))
+ (check-type object (and symbol (not null)))
+ (ecase doc-type
+ (variable (get object 'variable-documentation))
+ (function (get object 'function-documentation))
+ (structure (get object 'structure-documentation))
+ (type (get object 'type-documentation))
+ (setf (get object 'setf-documentation))
+ (compiler-macro (get object 'compiler-macro-documentation))
+ (method-combination (get object 'method-combination-documentation))
+ ((t) (when (find-package object) (get object 'package-documentation)))))
+(defun set-documentation (object doc-type value)
+ (cond ((typep object 'function)
+ (setq object (function-name object) doc-type 'function))
+ ((typep object 'package)
+ (setq object (find-symbol (package-name object) :keyword))))
+ (check-type object (and symbol (not null)))
+ (ecase doc-type
+ (variable (setf (get object 'variable-documentation) value))
+ (function (setf (get object 'function-documentation) value))
+ (structure (setf (get object 'structure-documentation) value))
+ (type (setf (get object 'type-documentation) value))
+ (setf (setf (get object 'setf-documentation) value))
+ (compiler-macro (setf (get object 'compiler-macro-documentation) value))
+ (method-combination (setf (get object 'method-combination-documentation)
value))
+ ((t) (when (find-package object) (setf (get object 'package-documentation)
value)))))
(defun find-documentation (body)
(if (or (endp body) (endp (cdr body)))
Index: lsp/gcl_setf.lsp
===================================================================
RCS file: /cvsroot/gcl/gcl/lsp/gcl_setf.lsp,v
retrieving revision 1.17
retrieving revision 1.18
diff -u -b -r1.17 -r1.18
--- lsp/gcl_setf.lsp 16 May 2006 16:44:59 -0000 1.17
+++ lsp/gcl_setf.lsp 5 Jun 2006 22:02:45 -0000 1.18
@@ -40,7 +40,7 @@
;(eval-when (compile) (proclaim '(optimize (safety 2) (space 3))))
-(eval-when (eval compile) (defun si:clear-compiler-properties (symbol)))
+;(eval-when (eval compile) (defun si:clear-compiler-properties (symbol code)))
(eval-when (eval compile) (setq si:*inhibit-macro-special* nil))
@@ -217,7 +217,7 @@
(defsetf svref si:svset)
(defsetf elt si:elt-set)
(defsetf symbol-value set)
-(defsetf symbol-function si:fset)
+(defsetf symbol-function si::fset)
(defsetf macro-function (s) (v) `(progn (si:fset ,s (cons 'macro ,v)) ,v))
(defsetf aref si:aset)
(defsetf get put-aux)
Index: lsp/gcl_top.lsp
===================================================================
RCS file: /cvsroot/gcl/gcl/lsp/gcl_top.lsp,v
retrieving revision 1.16
retrieving revision 1.17
diff -u -b -r1.16 -r1.17
--- lsp/gcl_top.lsp 21 Mar 2006 22:42:35 -0000 1.16
+++ lsp/gcl_top.lsp 5 Jun 2006 22:02:45 -0000 1.17
@@ -85,7 +85,7 @@
(defvar *top-eof* (cons nil nil))
(defvar *no-prompt* nil)
-(defun top-level ()
+(defun top-level1 ()
(let ((+ nil) (++ nil) (+++ nil)
(- nil)
(* nil) (** nil) (*** nil)
@@ -108,7 +108,7 @@
(package-name *package*))))
(reset-stack-limits)
;; have to exit and re-enter to multiply stacks
- (cond (*multiply-stacks* (Return-from top-level)))
+ (cond (*multiply-stacks* (Return-from top-level1)))
(when (catch *quit-tag*
(setq - (locally (declare (notinline read))
(read *standard-input* nil *top-eof*)))
@@ -126,6 +126,76 @@
(terpri *error-output*)
(break-current)))))
+(defun default-system-banner ()
+ (let (gpled-modules)
+ (dolist (l '(:unexec :bfd :readline))
+ (when (member l *features*)
+ (push l gpled-modules)))
+ (format nil "GCL (GNU Common Lisp) ~a.~a.~a ~a ~a ~a~%~a~%~a
~a~%~a~%~a~%~%~a~%"
+ *gcl-major-version* *gcl-minor-version* *gcl-extra-version*
+ (if (member :ansi-cl *features*) "ANSI" "CLtL1")
+ (if (member :gprof *features*) "profiling" "")
+ (si::gcl-compile-time)
+ "Source License: LGPL(gcl,gmp,pargcl), GPL(unexec,bfd)"
+ "Binary License: "
+ (if gpled-modules (format nil "GPL due to GPL'ed components: ~a"
gpled-modules)
+ "LGPL")
+ "Modifications of this banner must retain notice of a compatible
license"
+ "Dedicated to the memory of W. Schelter"
+ "Use (help) to get some basic information on how to use GCL.")))
+
+ (defvar *system-banner*)
+
+ (defun gcl-top-level ()
+
+ (set-up-top-level)
+
+ (if (get-command-arg "-compile")
+ (let (;(system::*quit-tag* (cons nil nil))
+ ;(system::*quit-tags* nil)
(system::*break-level* '())
+ ;(system::*break-env* nil)
(system::*ihs-base* 1)
+ ;(system::*ihs-top* 1)
(system::*current-ihs* 1)
+ (*break-enable* nil) result)
+ (setq result
+ (system:error-set
+ '(progn
+ (compile-file
+ (get-command-arg "-compile")
+ :output-file
+ (or (get-command-arg "-o")
+ (get-command-arg "-compile"))
+ :o-file
+ (cond ((equalp
+ (get-command-arg "-o-file")
+ "nil") nil)
+ ((get-command-arg "-o-file" t))
+ (t t))
+ :c-file (get-command-arg "-c-file" t)
+ :h-file (get-command-arg "-h-file" t)
+ :data-file (get-command-arg "-data-file" t)
+ :system-p (get-command-arg "-system-p" t)))))
+ (bye (if (or (and (find-package "COMPILER")
+ (find-symbol "*ERROR-P*" (find-package "COMPILER"))
+ (symbol-value (find-symbol "*ERROR-P*" (find-package
"COMPILER"))))
+ (equal result '(nil))) 1 0))))
+ (cond ((get-command-arg "-batch")
+ (setf *top-level-hook* #'bye))
+ ((get-command-arg "-f"))
+ (t (when (boundp '*gcl-major-version*)
+ (unless (boundp '*system-banner*) (setq *system-banner*
(default-system-banner))))
+ (when (boundp '*system-banner*)
+ (format t "~a~%" *system-banner*))
+ (let* ((c (find-package "COMPILER"))
+ (tmp (and c (find-symbol "*TMP-DIR*" c))))
+ (when tmp
+ (setf (symbol-value tmp) (funcall (find-symbol "GET-TEMP-DIR"
c)))
+ (format t "Temporary directory for compiler files set to ~a~%"
(symbol-value tmp))))))
+ (setq *ihs-top* 1)
+ (in-package 'system::user) (incf system::*ihs-top* 2)
+ (top-level1))
+
+(defun top-level nil (gcl-top-level))
+
(defun process-some-args (args)
(loop
(let ((x (car args))
@@ -251,6 +321,7 @@
(t (format *error-output* "~&Warning: ")
(let ((*indent-formatted-output* t))
(apply #'format *error-output* format-string args))
+ (terpri *error-output*)
nil))))
(defun universal-error-handler
@@ -655,15 +726,14 @@
;;make sure '/' terminated
-(defun coerce-slash-terminated (v )
- (declare (string v))
+(defun coerce-slash-terminated (v)
+ (declare (string v));(return-from coerce-slash-terminated v)
(or (stringp v) (error "not a string ~a" v))
(let ((n (length v)))
- (declare (fixnum n))
- (unless (and (> n 0) (eql
- (the character(aref v (the fixnum (- n 1)))) #\/))
+ (unless (and (> n 0) (eql (aref v (- n 1)) #\/))
(setf v (format nil "~a/" v))))
v)
+
(defun fix-load-path (l)
(when (not (equal l *fixed-load-path*))
(do ((x l (cdr x)) )
Index: lsp/makefile
===================================================================
RCS file: /cvsroot/gcl/gcl/lsp/makefile,v
retrieving revision 1.26
retrieving revision 1.27
diff -u -b -r1.26 -r1.27
--- lsp/makefile 24 Mar 2006 03:57:00 -0000 1.26
+++ lsp/makefile 5 Jun 2006 22:02:45 -0000 1.27
@@ -9,7 +9,7 @@
CAT=cat
APPEND=../xbin/append
-PREFS:= arraylib assert defmacro defstruct \
+PREFS:= recompile callhash arraylib assert defmacro defstruct \
describe evalmacros \
iolib listlib mislib module numlib \
packlib predlib \
@@ -73,3 +73,6 @@
$(MAKE) $(OBJS) -e "NEWCFILES=`echo $(OBJS) | sed -e 's:\.o:.c:g'`"
+gcl_recompile.lsp:
+ touch $@
+
Index: o/assignment.c
===================================================================
RCS file: /cvsroot/gcl/gcl/o/assignment.c,v
retrieving revision 1.20
retrieving revision 1.21
diff -u -b -r1.20 -r1.21
--- o/assignment.c 12 Oct 2005 03:12:57 -0000 1.20
+++ o/assignment.c 5 Jun 2006 22:02:45 -0000 1.21
@@ -139,6 +139,42 @@
RETURN1(value);
}
+DEFUNO_NEW("FUNCTION-NAME",object,fSfunction_name,SI
+ ,1,1,NONE,OO,OO,OO,OO,void,siLfunction_name,(object x),"") {
+
+ switch(type_of(x)) {
+ case t_sfun:
+ case t_gfun:
+ case t_vfun:
+ case t_afun:
+ case t_cfun:
+ x=x->cf.cf_name;
+ break;
+ case t_ifun:
+ x=x->ifn.ifn_self;
+ x=consp(x) ?
+ (x->c.c_car==sLlambda_block ?
+ x->c.c_cdr->c.c_car :
+ (x->c.c_car==sLlambda_block_closure ?
+ x->c.c_cdr->c.c_cdr->c.c_cdr->c.c_cdr->c.c_car : Cnil)) : Cnil;
+ break;
+ case t_closure:
+ case t_cclosure:
+ x=x->cc.cc_name;
+ break;
+ default:
+ TYPE_ERROR(x,sLfunction);
+ x=Cnil;
+ break;
+ }
+
+ return x;
+
+}
+
+
+
+
DEFUNO_NEW("FSET",object,fSfset,SI
,2,2,NONE,OO,OO,OO,OO,void,siLfset,(object sym,object function),"")
@@ -377,6 +413,7 @@
object y=args;
/* FIXME do a direct funcall here */
y=append(list(1,form),y);
+ x=type_of(x)==t_symbol ? symbol_function(x) : x;
y=MMcons(x,y);
y=MMcons(sLfuncall,y);
result=Ieval(y);
Index: o/fasdump.c
===================================================================
RCS file: /cvsroot/gcl/gcl/o/fasdump.c,v
retrieving revision 1.16
retrieving revision 1.17
diff -u -b -r1.16 -r1.17
--- o/fasdump.c 12 Oct 2005 03:12:57 -0000 1.16
+++ o/fasdump.c 5 Jun 2006 22:02:45 -0000 1.17
@@ -116,14 +116,14 @@
/* set whole structures! */
#define SETUP_FASD_IN(fd) do{ \
- fas_stream= (fd)->stream->sm.sm_fp; \
+ fas_stream= (fd)->stream; \
dump_index = fix((fd)->index) ; \
current_fasd= * (fd);}while(0)
#define SAVE_CURRENT_FASD \
struct fasd old_fd; \
int old_dump_index = dump_index; \
- FILE *old_fas_stream = fas_stream; \
+ object old_fas_stream = fas_stream; \
int old_needs_patching = needs_patching; \
old_fd = current_fasd;
@@ -153,7 +153,7 @@
#define FASD_VERSION 2
-FILE *fas_stream;
+object fas_stream;
int dump_index;
struct htent *gethash();
static void read_fasd1(int i, object *loc);
@@ -164,10 +164,10 @@
*/
/* #define DEBUG */
-#ifdef DEBUG
+#ifdef DEBUG /*FIXME debugging versions need sync with getc -> readc_stream,
etc.*/
-#define PUT(x) putc1((char)x,fas_stream)
-#define GET() getc1()
+#define PUT(x) writec_stream1((char)x,fas_stream)
+#define GET() readc_stream1()
#define D_FWRITE fwrite1
#define D_FREAD fread1
@@ -236,22 +236,22 @@
{printf("{");
printf(str,i);
printf("}");}
- putc(i,fas_stream);}
+ writec_stream(i,fas_stream);}
void
-putc1(x)
+writec_stream1(x)
int x;
{ if (debug) printf("(%x,%d,%c)",x,x,x);
- putc(x,fas_stream);
- fflush(stdout);
+ writec_stream(x,fas_stream);
+/* fflush(stdout); */
}
int
-getc1()
+readc_stream1()
{ int x;
- x= getc(fas_stream);
+ x= readc_stream(fas_stream);
if (debug) printf("(%x,%d,%c)",x,x,x);
- fflush(stdout);
+/* fflush(stdout); */
return x;
}
@@ -267,9 +267,9 @@
{printf("[");
n1=n1*n2;
for(i=0;i<n1; i++)
- putc(p[i],stdout);
+ writec_stream(p[i],sLAstandard_outputA->s.s_dbind);
printf("]");
- fflush(stdout);}
+/* fflush(stdout);} */
return j;
}
@@ -289,14 +289,14 @@
{printf("[");
n1=n1*n2;
for(i=0;i<n1; i++)
- putc(p[i],stdout);
+ writec_stream(p[i],sLAstandard_outputA->s.s_dbind);
printf("]");}
return j;
}
-#define GET_OP() (print_op(getc(fas_stream)))
-#define PUT_OP(x) fputc(print_op(x),fas_stream)
+#define GET_OP() ((unsigned)print_op((unsigned char)readc_stream(fas_stream)))
+#define PUT_OP(x) writec_stream(print_op(x),fas_stream)
#define DP(sw) sw /* if (debug) {printf("\ncase sw");} */
#define GETD(str) getd(str)
@@ -304,7 +304,7 @@
int
getd(str)
char *str;
-{ int i = getc(fas_stream);
+{ int i = (unsigned char)readc_stream(fas_stream);
if(debug){
printf("{");
printf(str,i);
@@ -312,16 +312,19 @@
return i;}
#define DPRINTF(a,b) do{if(debug) printf(a,b);} while(0)
#else
-#define PUT(x) putc((char)x,fas_stream)
-#define GET() getc(fas_stream)
+#define PUT(x) writec_stream((char)x,fas_stream)
+#define GET() ((unsigned char)readc_stream(fas_stream))
#define GET_OP GET
#define PUT_OP PUT
-#define D_FWRITE fwrite
-#define D_FREAD SAFE_FREAD
+#define D_FWRITE fwrite_int
+#define D_FREAD fread_int
#define DP(sw) sw
#define PUTD(a,b) PUT(b)
#define GETD(a) GET()
#define DPRINTF(a,b)
+#define fwrite_int(a_,b_,c_,d_) {register char *_p=(a_),*_pe=_p+(b_)*(c_);for
(;_p<_pe;) writec_stream(*_p++,(d_));}
+#define fread_int(a_,b_,c_,d_) {register char *_p=(a_),*_pe=_p+(b_)*(c_);for
(;_p<_pe;) *_p++=readc_stream(d_);}
+
#endif
@@ -342,7 +345,7 @@
#define MAKE_SHORT(top,bot) (((top)<< SIZE_BYTE) + (bot))
-#define READ_BYTE1() getc(fas_stream)
+#define READ_BYTE1() ((unsigned char)readc_stream(fas_stream))
#define GET8(varx ) \
do{unsigned long var=(unsigned long)READ_BYTE1(); \
@@ -380,7 +383,7 @@
#define MASK ~(~0 << 8)
-#define WRITE_BYTEI(x,i) putc((((x) >> (i*SIZE_BYTE)) & MASK),fas_stream)
+#define WRITE_BYTEI(x,i) writec_stream((((x) >> (i*SIZE_BYTE)) &
MASK),fas_stream)
#define PUTFIX(v_) Join(PUT,SIZEOF_LONG)(v_)
#define GETFIX(v_) Join(GET,SIZEOF_LONG)(v_)
@@ -1091,12 +1094,12 @@
-#define CHECK_CH(i) do{if ((i)==EOF && feof(fas_stream))
bad_eof();}while (0)
+#define CHECK_CH(i) do{if ((i)==EOF &&
stream_at_end(fas_stream)) bad_eof();}while (0)
/* grow vector AR of general type */
static void
grow_vector(object ar)
{ int len=ar->v.v_dim;
- int nl=(int) (1.5*len);
+ int nl=(int) (1.5*(len+1));
{BEGIN_NO_INTERRUPT;
{char *p= (char *)AR_ALLOC(alloc_contblock,nl,object);
bcopy(ar->v.v_self,p,sizeof(object)* len);
@@ -1496,7 +1499,7 @@
object orig = in;
object d;
int tem;
- if (((tem=getc(in->sm.sm_fp)) == EOF) && feof(in->sm.sm_fp))
+ if (((tem=(unsigned char)readc_stream(in)) == EOF) && stream_at_end(in))
{ d = coerce_to_pathname(in);
d = make_pathname(d->pn.pn_host,
d->pn.pn_device,
@@ -1511,9 +1514,9 @@
FEerror("Can't open file ~s",1,d);
}
else if (tem != EOF)
- { ungetc(tem,in->sm.sm_fp);}
+ { unreadc_stream(tem,in);}
while (1)
- { ch=readc_stream(in);
+ { ch=(unsigned char)readc_stream(in);
if (ch=='#')
{unreadc_stream(ch,in);
return read_fasl_vector1(in);}
Index: o/file.d
===================================================================
RCS file: /cvsroot/gcl/gcl/o/file.d,v
retrieving revision 1.61
retrieving revision 1.62
diff -u -b -r1.61 -r1.62
--- o/file.d 21 Mar 2006 22:38:24 -0000 1.61
+++ o/file.d 5 Jun 2006 22:02:45 -0000 1.62
@@ -1717,11 +1717,12 @@
return(0);
case smm_string_output:
- if (disp < STRING_STREAM_STRING(strm)->st.st_fillp) {
+ if (disp < STRING_STREAM_STRING(strm)->st.st_dim) {
STRING_STREAM_STRING(strm)->st.st_fillp = disp;
/* strm->sm.sm_int0 = disp; */
} else {
- disp -= STRING_STREAM_STRING(strm)->st.st_fillp;
+ disp -= (STRING_STREAM_STRING(strm)->st.st_fillp=
+ STRING_STREAM_STRING(strm)->st.st_dim);
while (disp-- > 0)
writec_stream(' ', strm);
}
@@ -2534,8 +2535,9 @@
DEFVAR("*COLLECT-BINARY-MODULES*",sSAcollect_binary_modulesA,SI,sLnil,"");
DEFVAR("*BINARY-MODULES*",sSAbinary_modulesA,SI,Cnil,"");
+DEFVAR("*DISABLE-RECOMPILE*",sSAdisable_recompile,SI,Ct,"");
-@(static defun load (pathname
+@(static defun load1 (pathname
&key (verbose `symbol_value(sLAload_verboseA)`)
(print `symbol_value(sLAload_printA)`)
(if_does_not_exist sKerror)
@@ -2862,9 +2864,17 @@
case smm_output:
if (!out) cannot_read(strm);
break;
+ case smm_string_output:
+ if (!out) cannot_read(strm);
+ return (strm);
+ break;
case smm_input:
if (out) cannot_write(strm);
break;
+ case smm_string_input:
+ if (out) cannot_write(strm);
+ return (strm);
+ break;
case smm_io:
/* case smm_socket: */
break;
@@ -3409,7 +3419,7 @@
/* make_function("READ-SEQUENCE", Lread_sequence); */
/* make_function("WRITE-SEQUENCE", Lwrite_sequence); */
- make_function("LOAD", Lload);
+ make_function("LOAD1", Lload1);
make_si_function("GET-STRING-INPUT-STREAM-INDEX",
siLget_string_input_stream_index);
Index: o/funlink.c
===================================================================
RCS file: /cvsroot/gcl/gcl/o/funlink.c,v
retrieving revision 1.26
retrieving revision 1.27
diff -u -b -r1.26 -r1.27
--- o/funlink.c 22 Jun 2005 01:37:26 -0000 1.26
+++ o/funlink.c 5 Jun 2006 22:02:45 -0000 1.27
@@ -46,7 +46,7 @@
void
call_or_link(object sym,int setf,void **link) {
- object fun = setf ? get(sym,sSsetf_function,OBJNULL) : sym->s.s_gfdef;
+ object fun = setf ? ({object ns=get(sym,sSsetf_function,OBJNULL);
type_of(ns)!=t_symbol ? ns : symbol_function(ns);}) : sym->s.s_gfdef;
#ifdef DO_FUNLINK_DEBUG
fprintf ( stderr, "call_or_link: fun %x START for function ", fun );
print_lisp_string ( "name: ", fun->cf.cf_name );
@@ -99,7 +99,7 @@
void
call_or_link_closure ( object sym, int setf, void **link, void **ptr )
{
- object fun = setf ? get(sym,sSsetf_function,OBJNULL) : sym->s.s_gfdef;
+ object fun = setf ? ({object ns=get(sym,sSsetf_function,OBJNULL);
type_of(ns)!=t_symbol ? ns : symbol_function(ns);}) : sym->s.s_gfdef;
#ifdef DO_FUNLINK_DEBUG
fprintf ( stderr, "call_or_link_closure: START sym %x, link %x, *link %x,
ptr %x, *ptr %x, sym->s.s_gfdef (fun) %x ",
sym, link, *link, ptr, *ptr, fun );
@@ -310,7 +310,9 @@
extern object sSclear_compiler_properties;
VFUN_NARGS=2; FFN(fSuse_fast_links)(Cnil,sym);
tem = getf(sym->s.s_plist,sStraced,Cnil);
- if (sSAinhibit_macro_specialA && sSAinhibit_macro_specialA->s.s_dbind !=
Cnil)
+ if (sSclear_compiler_properties &&
sSclear_compiler_properties->s.s_gfdef!=OBJNULL)
+ if ((sSAinhibit_macro_specialA && sSAinhibit_macro_specialA->s.s_dbind !=
Cnil) ||
+ sym->s.s_sfdef == NOT_SPECIAL)
(void)ifuncall2(sSclear_compiler_properties, sym,code);
if (tem != Cnil) return tem;
return sym;
@@ -1209,7 +1211,7 @@
fprintf ( stderr, "call_proc: sym %x START\n", sym );
#endif
check_type_symbol(&sym);
- fun = setf ? get(sym,sSsetf_function,OBJNULL) : sym->s.s_gfdef;
+ fun = setf ? ({object ns=get(sym,sSsetf_function,OBJNULL);
type_of(ns)!=t_symbol ? ns : symbol_function(ns);}) : sym->s.s_gfdef;
if (fun && (type_of(fun)==t_sfun
|| type_of(fun)==t_gfun
|| type_of(fun)== t_vfun)
@@ -1293,7 +1295,7 @@
register object *base;
enum ftype result_type;
/* we check they are valid functions before calling this */
- if(type_of(sym)==t_symbol) fun = setf ? get(sym,sSsetf_function,OBJNULL)
: symbol_function(sym);
+ if(type_of(sym)==t_symbol) fun = setf ? ({object
ns=get(sym,sSsetf_function,OBJNULL); type_of(ns)!=t_symbol ? ns :
symbol_function(ns);}) : symbol_function(sym);
else fun = sym;
vs_base= (base = vs_top);
if (fun == OBJNULL || sym->s.s_sfdef != NOT_SPECIAL || sym->s.s_mflag)
FEinvalid_function(sym);
@@ -1340,7 +1342,7 @@
fprintf ( stderr, "call_proc_new: sym %x START\n", sym );
#endif
check_type_symbol(&sym);
- fun = setf ? get(sym,sSsetf_function,OBJNULL) : sym->s.s_gfdef;
+ fun = setf ? ({object ns=get(sym,sSsetf_function,OBJNULL);
type_of(ns)!=t_symbol ? ns : symbol_function(ns);}) : sym->s.s_gfdef;
if (fun && (type_of(fun)==t_sfun
|| type_of(fun)==t_gfun
|| type_of(fun)== t_vfun)
@@ -1426,7 +1428,7 @@
register object *base;
enum ftype result_type;
/* we check they are valid functions before calling this */
- if(type_of(sym)==t_symbol) fun = setf ? get(sym,sSsetf_function,OBJNULL)
: symbol_function(sym);
+ if(type_of(sym)==t_symbol) fun = setf ? ({object
ns=get(sym,sSsetf_function,OBJNULL); type_of(ns)!=t_symbol ? ns :
symbol_function(ns);}) : symbol_function(sym);
else fun = sym;
vs_base= (base = vs_top);
if (fun == OBJNULL || sym->s.s_sfdef != NOT_SPECIAL || sym->s.s_mflag)
FEinvalid_function(sym);
Index: o/read.d
===================================================================
RCS file: /cvsroot/gcl/gcl/o/read.d,v
retrieving revision 1.42
retrieving revision 1.43
diff -u -b -r1.42 -r1.43
--- o/read.d 16 May 2006 16:46:30 -0000 1.42
+++ o/read.d 5 Jun 2006 22:02:45 -0000 1.43
@@ -52,7 +52,7 @@
.rte_chatrait)
#ifndef SHARP_EQ_CONTEXT_SIZE
-#define SHARP_EQ_CONTEXT_SIZE 500
+#define SHARP_EQ_CONTEXT_SIZE 4096
#endif
static void
Index: o/reference.c
===================================================================
RCS file: /cvsroot/gcl/gcl/o/reference.c,v
retrieving revision 1.13
retrieving revision 1.14
diff -u -b -r1.13 -r1.14
--- o/reference.c 31 Mar 2006 21:59:39 -0000 1.13
+++ o/reference.c 5 Jun 2006 22:02:45 -0000 1.14
@@ -136,6 +136,7 @@
if (!endp(MMcdr(form)))
FEtoo_many_argumentsF(form);
fun = MMcar(form);
+ AGAIN:
if (type_of(fun) == t_symbol) {
fd = lex_fd_sch(fun);
if (MMnull(fd) || MMcadr(fd) != sLfunction)
@@ -162,13 +163,12 @@
vs_base[0]=x;
}
} else if (setf_fn_form(fun)) {
- object setf_fn_def=get(MMcadr(fun),sSsetf_function,Cnil);
- if (setf_fn_def==Cnil)
+ fun=get(MMcadr(fun),sSsetf_function,Cnil);
+ if (fun==Cnil)
FEundefined_function(fun);
- else {
- vs_base = vs_top;
- vs_push(setf_fn_def);
- }
+ else if (type_of(fun)==t_symbol)
+ goto AGAIN;
+ else vs_base[0]=fun;
} else
FEinvalid_function(fun);
}
Index: o/toplevel.c
===================================================================
RCS file: /cvsroot/gcl/gcl/o/toplevel.c,v
retrieving revision 1.13
retrieving revision 1.14
diff -u -b -r1.13 -r1.14
--- o/toplevel.c 6 Oct 2005 20:30:09 -0000 1.13
+++ o/toplevel.c 5 Jun 2006 22:02:45 -0000 1.14
@@ -72,8 +72,7 @@
}
if (name->s.s_hpack == lisp_package &&
name->s.s_gfdef != OBJNULL && initflag) {
- vs_push(make_simple_string(
- "~S is being redefined."));
+ vs_push(make_simple_string("~S is being redefined."));
ifuncall2(sLwarn, vs_head, name);
vs_popp;
}
Index: pcl/gcl_pcl_std_class.lisp
===================================================================
RCS file: /cvsroot/gcl/gcl/pcl/gcl_pcl_std_class.lisp,v
retrieving revision 1.2
retrieving revision 1.3
diff -u -b -r1.2 -r1.3
--- pcl/gcl_pcl_std_class.lisp 7 May 2005 02:52:30 -0000 1.2
+++ pcl/gcl_pcl_std_class.lisp 5 Jun 2006 22:02:45 -0000 1.3
@@ -117,8 +117,7 @@
(lisp:documentation object doc-type))
(defmethod (setf documentation) (new-value object &optional doc-type)
- (declare (ignore new-value doc-type))
- (error "Can't change the documentation of ~S." object))
+ (si::set-documentation object doc-type new-value))
(defmethod documentation ((object documentation-mixin) &optional doc-type)
Index: pcl/makefile
===================================================================
RCS file: /cvsroot/gcl/gcl/pcl/makefile,v
retrieving revision 1.21
retrieving revision 1.22
diff -u -b -r1.21 -r1.22
--- pcl/makefile 24 Mar 2006 03:57:00 -0000 1.21
+++ pcl/makefile 5 Jun 2006 22:02:45 -0000 1.22
@@ -19,7 +19,7 @@
'(setq compiler::*default-c-file* t)'\
'(setq compiler::*default-data-file* t)'\
'(setq compiler::*default-system-p* t)' \
- '(setq compiler::*keep-gaz* t compiler::*tmp-dir* "")'
+ '(setq compiler::*keep-gaz* t compiler::*tmp-dir* ""
si::*disable-recompile* t)'
all: $(addsuffix .c,$(AFILES)) $(addsuffix .o,$(AFILES))
@@ -68,3 +68,4 @@
tar1:
(cd .. ; tar cvf - `basename ${DIR}` | gzip -c > `basename ${DIR}`.tgz)
+.PRECIOUS: gcl_pcl_boot.c
\ No newline at end of file
Index: unixport/init_ansi_gcl.lsp.in
===================================================================
RCS file: /cvsroot/gcl/gcl/unixport/init_ansi_gcl.lsp.in,v
retrieving revision 1.25
retrieving revision 1.26
diff -u -b -r1.25 -r1.26
--- unixport/init_ansi_gcl.lsp.in 18 Apr 2006 04:38:06 -0000 1.25
+++ unixport/init_ansi_gcl.lsp.in 5 Jun 2006 22:02:46 -0000 1.26
@@ -94,59 +94,12 @@
(if (si::fread tem 0 (length tem) st)
(setq compiler::*cmpinclude-string* tem))))))
- (setf (symbol-function 'si:clear-compiler-properties)
- (symbol-function 'compiler::compiler-clear-compiler-properties))
- (setq system::*old-top-level* (symbol-function 'system:top-level))
-
(defvar si::*lib-directory* (namestring (make-pathname :directory (list
:parent))))
- (defun system::gcl-top-level (&aux tem)
- (si::set-up-top-level)
-
- (if (si::get-command-arg "-compile")
- (let (;(system::*quit-tag* (cons nil nil))
- ;(system::*quit-tags* nil) (system::*break-level* '())
- ;(system::*break-env* nil) (system::*ihs-base* 1)
- ;(system::*ihs-top* 1) (system::*current-ihs* 1)
- (*break-enable* nil) result)
- (setq result
- (system:error-set
- '(progn
- (compile-file
- (si::get-command-arg "-compile")
- :output-file
- (or (si::get-command-arg "-o")
- (si::get-command-arg "-compile"))
- :o-file
- (cond ((equalp
- (si::get-command-arg "-o-file")
- "nil") nil)
- ((si::get-command-arg "-o-file" t))
- (t t))
- :c-file (si::get-command-arg "-c-file" t)
- :h-file (si::get-command-arg "-h-file" t)
- :data-file (si::get-command-arg "-data-file" t)
- :system-p (si::get-command-arg "-system-p" t)))))
- (bye (if (or compiler::*error-p* (equal result '(nil))) 1 0))))
- (cond ((si::get-command-arg "-batch")
- (setf si::*top-level-hook* #'si::bye))
- ((si::get-command-arg "-f"))
- (t (format t si::*system-banner*)
- (let* ((c (find-package "COMPILER"))
- (tmp (and c (find-symbol "*TMP-DIR*" c))))
- (when tmp
- (setf (symbol-value tmp) (funcall (find-symbol "GET-TEMP-DIR"
c)))
- (format t "Temporary directory for compiler files set to ~a~%"
(symbol-value tmp))))))
- (setq si::*ihs-top* 1)
- (in-package 'system::user) (incf system::*ihs-top* 2)
- (funcall system::*old-top-level*))
-
(terpri)
(setq si:*inhibit-macro-special* t)
(gbc t) (system:reset-gbc-count)
- (defun system:top-level nil (system::gcl-top-level))
-
(setq compiler::*default-c-file* nil)
(setq compiler::*default-h-file* nil)
(setq compiler::*default-data-file* nil)
@@ -287,20 +240,7 @@
(import (list s) "COMMON-LISP")
(import (list s) "USER"))))
- (setf (symbol-function 'compiler::compile-file)
- (let ((old (symbol-function 'compiler::compile-file)))
- (lambda (&rest args)
- (let (warnings failures)
- (conditions::handler-bind
- ((warning (lambda (c)
- (setq warnings t)
- (unless (typep c 'style-warning)
- (setq failures t))
- (when (not compiler::*compile-verbose*)
- (conditions::invoke-restart
- (conditions::find-restart
'conditions::muffle-warning c)))))
- (error (lambda (c) (setq failures t))))
- (values (apply old args) warnings failures))))))
+
t)
(progn
@@ -361,6 +301,10 @@
(setf system:*default-time-zone* 6)))
(if (fboundp 'si::user-init) (si::user-init))
+ (setq si::*disable-recompile* nil)
+ (si::do-recompile "gcl_recompile.lsp")
+ (maphash (lambda (x y) (when (si::call-sig y) (proclaim `(ftype (function
,@(si::call-sig y)) ,x)))) si::*call-hash-table*)
+ (conditions::install-clcs-symbols)
(si::set-up-top-level)
(setq si::*gcl-extra-version* @LI-EXTVERS@
Index: unixport/init_gcl.lsp.in
===================================================================
RCS file: /cvsroot/gcl/gcl/unixport/init_gcl.lsp.in,v
retrieving revision 1.23
retrieving revision 1.24
diff -u -b -r1.23 -r1.24
--- unixport/init_gcl.lsp.in 18 Apr 2006 04:38:06 -0000 1.23
+++ unixport/init_gcl.lsp.in 5 Jun 2006 22:02:46 -0000 1.24
@@ -32,8 +32,8 @@
(cmpnew (append x (list "cmpnew")))
(h (append x (list "h")))
(gtk (append x (list "gcl-tk"))))
- (dolist (d (list lsp cmpnew))
- (load (make-pathname :name "sys-proclaim" :type "lisp" :directory d)))
+; (dolist (d (list lsp cmpnew))
+; (load (make-pathname :name "sys-proclaim" :type "lisp" :directory d)))
(load (make-pathname :name "tk-package" :type "lsp" :directory gtk))
; (load (make-pathname :name "gcl_cmpmain" :type "lsp" :directory cmpnew))
(load (make-pathname :name "gcl_lfun_list" :type "lsp" :directory cmpnew))
@@ -52,59 +52,12 @@
(if (si::fread tem 0 (length tem) st)
(setq compiler::*cmpinclude-string* tem))))))
- (setf (symbol-function 'si:clear-compiler-properties)
- (symbol-function 'compiler::compiler-clear-compiler-properties))
- (setq system::*old-top-level* (symbol-function 'system:top-level))
-
(defvar si::*lib-directory* (namestring (make-pathname :directory (list
:parent))))
- (defun system::gcl-top-level (&aux tem)
- (si::set-up-top-level)
-
- (if (si::get-command-arg "-compile")
- (let (;(system::*quit-tag* (cons nil nil))
- ;(system::*quit-tags* nil)
(system::*break-level* '())
- ;(system::*break-env* nil)
(system::*ihs-base* 1)
- ;(system::*ihs-top* 1)
(system::*current-ihs* 1)
- (*break-enable* nil) result)
- (setq result
- (system:error-set
- '(progn
- (compile-file
- (si::get-command-arg "-compile")
- :output-file
- (or (si::get-command-arg "-o")
- (si::get-command-arg "-compile"))
- :o-file
- (cond ((equalp
- (si::get-command-arg "-o-file")
- "nil") nil)
- ((si::get-command-arg "-o-file" t))
- (t t))
- :c-file (si::get-command-arg "-c-file" t)
- :h-file (si::get-command-arg "-h-file" t)
- :data-file (si::get-command-arg "-data-file" t)
- :system-p (si::get-command-arg "-system-p" t)))))
- (bye (if (or compiler::*error-p* (equal result '(nil))) 1 0))))
- (cond ((si::get-command-arg "-batch")
- (setf si::*top-level-hook* #'si::bye))
- ((si::get-command-arg "-f"))
- (t (format t si::*system-banner*)
- (let* ((c (find-package "COMPILER"))
- (tmp (and c (find-symbol "*TMP-DIR*" c))))
- (when tmp
- (setf (symbol-value tmp) (funcall (find-symbol "GET-TEMP-DIR"
c)))
- (format t "Temporary directory for compiler files set to ~a~%"
(symbol-value tmp))))))
- (setq si::*ihs-top* 1)
- (in-package 'system::user) (incf system::*ihs-top* 2)
- (funcall system::*old-top-level*))
-
(terpri)
(setq si:*inhibit-macro-special* t)
(gbc t) (system:reset-gbc-count)
- (defun system:top-level nil (system::gcl-top-level))
-
(setq compiler::*default-c-file* nil)
(setq compiler::*default-h-file* nil)
(setq compiler::*default-data-file* nil)
@@ -122,8 +75,15 @@
(setf system:*default-time-zone* (get-system-time-zone))
(setf system:*default-time-zone* 6)))
- (if (fboundp 'si::user-init) (si::user-init))
(si::set-up-top-level)
+ (if (fboundp 'si::user-init) (si::user-init))
+;(break)
+; (si::use-fast-links nil)
+ (setq si::*disable-recompile* nil)
+ (si::do-recompile "gcl_recompile.lsp")
+ (maphash (lambda (x y) (when (si::call-sig y) (proclaim `(ftype (function
,@(si::call-sig y)) ,x)))) si::*call-hash-table*)
+; (si::use-fast-links t)
+; (si::set-up-top-level)
(setq si::*gcl-extra-version* @LI-EXTVERS@
si::*gcl-minor-version* @LI-MINVERS@
Index: unixport/init_mod_gcl.lsp.in
===================================================================
RCS file: /cvsroot/gcl/gcl/unixport/init_mod_gcl.lsp.in,v
retrieving revision 1.10
retrieving revision 1.11
diff -u -b -r1.10 -r1.11
--- unixport/init_mod_gcl.lsp.in 18 Apr 2006 04:38:06 -0000 1.10
+++ unixport/init_mod_gcl.lsp.in 5 Jun 2006 22:02:46 -0000 1.11
@@ -43,61 +43,14 @@
(if (si::fread tem 0 (length tem) st)
(setq compiler::*cmpinclude-string* tem)))))
- (setf (symbol-function 'si:clear-compiler-properties)
- (symbol-function 'compiler::compiler-clear-compiler-properties))
- (setq system::*old-top-level* (symbol-function 'system:top-level))
-
(defvar si::*lib-directory* (namestring "../"))
- (defun system::gcl-top-level (&aux tem)
- (si::set-up-top-level)
-
- (if (si::get-command-arg "-compile")
- (let (;(system::*quit-tag* (cons nil nil))
- ;(system::*quit-tags* nil)
(system::*break-level* '())
- ;(system::*break-env* nil)
(system::*ihs-base* 1)
- ;(system::*ihs-top* 1)
(system::*current-ihs* 1)
- (*break-enable* nil) result)
- (setq result
- (system:error-set
- '(progn
- (compile-file
- (si::get-command-arg "-compile")
- :output-file
- (or (si::get-command-arg "-o")
- (si::get-command-arg "-compile"))
- :o-file
- (cond ((equalp
- (si::get-command-arg "-o-file")
- "nil") nil)
- ((si::get-command-arg "-o-file" t))
- (t t))
- :c-file (si::get-command-arg "-c-file" t)
- :h-file (si::get-command-arg "-h-file" t)
- :data-file (si::get-command-arg "-data-file" t)
- :system-p (si::get-command-arg "-system-p" t)))))
- (bye (if (or compiler::*error-p* (equal result '(nil))) 1 0))))
- (cond ((si::get-command-arg "-batch")
- (setf si::*top-level-hook* #'si::bye))
- ((si::get-command-arg "-f"))
- (t (format t si::*system-banner*)
- (let* ((c (find-package "COMPILER"))
- (tmp (and c (find-symbol "*TMP-DIR*" c))))
- (when tmp
- (setf (symbol-value tmp) (funcall (find-symbol "GET-TEMP-DIR"
c)))
- (format t "Temporary directory for compiler files set to ~a~%"
(symbol-value tmp))))))
- (setq si::*ihs-top* 1)
- (in-package 'system::user) (incf system::*ihs-top* 2)
- (funcall system::*old-top-level*))
-
(defun lisp-implementation-version nil (format nil "GCL-~a-~a"
si::*gcl-major-version* si::*gcl-version*))
(terpri)
(setq si:*inhibit-macro-special* t)
(gbc t) (system:reset-gbc-count)
- (defun system:top-level nil (system::gcl-top-level))
-
(setq compiler::*default-c-file* nil)
(setq compiler::*default-h-file* nil)
(setq compiler::*default-data-file* nil)
@@ -116,6 +69,9 @@
(setf system:*default-time-zone* 6)))
(if (fboundp 'si::user-init) (si::user-init))
+ (setq si::*disable-recompile* nil)
+ (si::do-recompile "gcl_recompile.lsp")
+ (maphash (lambda (x y) (when (si::call-sig y) (proclaim `(ftype (function
,@(si::call-sig y)) ,x)))) si::*call-hash-table*)
(si::set-up-top-level)
(setq si::*gcl-version* @LI-MINVERS@ si::*gcl-major-version* @LI-MAJVERS@)
Index: unixport/init_pcl_gcl.lsp.in
===================================================================
RCS file: /cvsroot/gcl/gcl/unixport/init_pcl_gcl.lsp.in,v
retrieving revision 1.15
retrieving revision 1.16
diff -u -b -r1.15 -r1.16
--- unixport/init_pcl_gcl.lsp.in 18 Apr 2006 04:38:06 -0000 1.15
+++ unixport/init_pcl_gcl.lsp.in 5 Jun 2006 22:02:46 -0000 1.16
@@ -59,59 +59,12 @@
(if (si::fread tem 0 (length tem) st)
(setq compiler::*cmpinclude-string* tem))))))
- (setf (symbol-function 'si:clear-compiler-properties)
- (symbol-function 'compiler::compiler-clear-compiler-properties))
- (setq system::*old-top-level* (symbol-function 'system:top-level))
-
(defvar si::*lib-directory* (namestring (make-pathname :directory (list
:parent))))
- (defun system::gcl-top-level (&aux tem)
- (si::set-up-top-level)
-
- (if (si::get-command-arg "-compile")
- (let (;(system::*quit-tag* (cons nil nil))
- ;(system::*quit-tags* nil) (system::*break-level* '())
- ;(system::*break-env* nil) (system::*ihs-base* 1)
- ;(system::*ihs-top* 1) (system::*current-ihs* 1)
- (*break-enable* nil) result)
- (setq result
- (system:error-set
- '(progn
- (compile-file
- (si::get-command-arg "-compile")
- :output-file
- (or (si::get-command-arg "-o")
- (si::get-command-arg "-compile"))
- :o-file
- (cond ((equalp
- (si::get-command-arg "-o-file")
- "nil") nil)
- ((si::get-command-arg "-o-file" t))
- (t t))
- :c-file (si::get-command-arg "-c-file" t)
- :h-file (si::get-command-arg "-h-file" t)
- :data-file (si::get-command-arg "-data-file" t)
- :system-p (si::get-command-arg "-system-p" t)))))
- (bye (if (or compiler::*error-p* (equal result '(nil))) 1 0))))
- (cond ((si::get-command-arg "-batch")
- (setf si::*top-level-hook* #'si::bye))
- ((si::get-command-arg "-f"))
- (t (format t si::*system-banner*)
- (let* ((c (find-package "COMPILER"))
- (tmp (and c (find-symbol "*TMP-DIR*" c))))
- (when tmp
- (setf (symbol-value tmp) (funcall (find-symbol "GET-TEMP-DIR"
c)))
- (format t "Temporary directory for compiler files set to ~a~%"
(symbol-value tmp))))))
- (setq si::*ihs-top* 1)
- (in-package 'system::user) (incf system::*ihs-top* 2)
- (funcall system::*old-top-level*))
-
(terpri)
(setq si:*inhibit-macro-special* t)
(gbc t) (system:reset-gbc-count)
- (defun system:top-level nil (system::gcl-top-level))
-
(setq compiler::*default-c-file* nil)
(setq compiler::*default-h-file* nil)
(setq compiler::*default-data-file* nil)
@@ -134,6 +87,9 @@
(setf system:*default-time-zone* 6)))
(if (fboundp 'si::user-init) (si::user-init))
+ (setq si::*disable-recompile* nil)
+ (si::do-recompile "gcl_recompile.lsp")
+ (maphash (lambda (x y) (when (si::call-sig y) (proclaim `(ftype (function
,@(si::call-sig y)) ,x)))) si::*call-hash-table*)
(si::set-up-top-level)
(setq si::*gcl-extra-version* @LI-EXTVERS@
Index: unixport/init_pre_gcl.lsp.in
===================================================================
RCS file: /cvsroot/gcl/gcl/unixport/init_pre_gcl.lsp.in,v
retrieving revision 1.12
retrieving revision 1.13
diff -u -b -r1.12 -r1.13
--- unixport/init_pre_gcl.lsp.in 16 Jan 2006 21:41:02 -0000 1.12
+++ unixport/init_pre_gcl.lsp.in 5 Jun 2006 22:02:46 -0000 1.13
@@ -51,59 +51,15 @@
(if (si::fread tem 0 (length tem) st)
(setq compiler::*cmpinclude-string* tem))))))
- (setf (symbol-function 'si:clear-compiler-properties)
- (symbol-function 'compiler::compiler-clear-compiler-properties))
- (setq system::*old-top-level* (symbol-function 'system:top-level))
+; (setf (symbol-function 'si:clear-compiler-properties)
+; (symbol-function 'compiler::compiler-clear-compiler-properties))
(defvar si::*lib-directory* (namestring (make-pathname :directory (list
:parent))))
- (defun system::gcl-top-level (&aux tem)
- (si::set-up-top-level)
-
- (if (si::get-command-arg "-compile")
- (let (;(system::*quit-tag* (cons nil nil))
- ;(system::*quit-tags* nil)
(system::*break-level* '())
- ;(system::*break-env* nil)
(system::*ihs-base* 1)
- ;(system::*ihs-top* 1)
(system::*current-ihs* 1)
- (*break-enable* nil) result)
- (setq result
- (system:error-set
- '(progn
- (compile-file
- (si::get-command-arg "-compile")
- :output-file
- (or (si::get-command-arg "-o")
- (si::get-command-arg "-compile"))
- :o-file
- (cond ((equalp
- (si::get-command-arg "-o-file")
- "nil") nil)
- ((si::get-command-arg "-o-file" t))
- (t t))
- :c-file (si::get-command-arg "-c-file" t)
- :h-file (si::get-command-arg "-h-file" t)
- :data-file (si::get-command-arg "-data-file" t)
- :system-p (si::get-command-arg "-system-p" t)))))
- (bye (if (or compiler::*error-p* (equal result '(nil))) 1 0))))
- (cond ((si::get-command-arg "-batch")
- (setf si::*top-level-hook* #'si::bye))
- ((si::get-command-arg "-f"))
- (t (format t si::*system-banner*)
- (let* ((c (find-package "COMPILER"))
- (tmp (and c (find-symbol "*TMP-DIR*" c))))
- (when tmp
- (setf (symbol-value tmp) (funcall (find-symbol "GET-TEMP-DIR"
c)))
- (format t "Temporary directory for compiler files set to ~a~%"
(symbol-value tmp))))))
- (setq si::*ihs-top* 1)
- (in-package 'system::user) (incf system::*ihs-top* 2)
- (funcall system::*old-top-level*))
-
(terpri)
(setq si:*inhibit-macro-special* t)
(gbc t) (system:reset-gbc-count)
- (defun system:top-level nil (system::gcl-top-level))
-
(setq compiler::*default-c-file* nil)
(setq compiler::*default-h-file* nil)
(setq compiler::*default-data-file* nil)
Index: unixport/makefile
===================================================================
RCS file: /cvsroot/gcl/gcl/unixport/makefile,v
retrieving revision 1.71
retrieving revision 1.72
diff -u -b -r1.71 -r1.72
--- unixport/makefile 24 Mar 2006 03:57:00 -0000 1.71
+++ unixport/makefile 5 Jun 2006 22:02:46 -0000 1.72
@@ -46,8 +46,9 @@
OOBJS:=$(filter-out $(FIRST_FILE),$(OOBJS))
OOBJS:=$(filter-out $(LAST_FILE),$(OOBJS))
OOBJS:=$(filter-out $(ODIR)/plttest.o,$(OOBJS))
-OBJS:=$(OOBJS) $(shell ls -1 $(LSPDIR)/*.o)
+OBJS:=$(OOBJS) $(shell ls -1 $(LSPDIR)/*.o | grep -v recompile.o)
OBJS:=$(OBJS) $(shell ls -1 $(CMPDIR)/*.o | grep -v collectfn.o)
+OBJS:=$(OBJS) gcl_recompile.o
MODOBJS:=$(shell ls -1 $(MDIR)/*.o)
PCLOBJS:=$(MODOBJS) $(shell ls -1 $(PCLDIR)/*.o)
@@ -115,7 +116,13 @@
cp init_$*.lsp foo
echo " (in-package \"USER\")(system:save-system \"address@hidden")"
>>foo
# cp $(PORTDIR)/raw_$*$(EXE) $(PORTDIR)/raw_$*.bak$(EXE)
+ rm -f gcl_recompile*
+ $(MAKE) raw_$*$(EXE)
$(PORTDIR)/raw_$*$(EXE) $(PORTDIR)/ $(LISPFLAGS) -libdir $(GCLDIR)/ <
foo
+ $(MAKE) raw_$*$(EXE)
+ $(PORTDIR)/raw_$*$(EXE) $(PORTDIR)/ $(LISPFLAGS) -libdir $(GCLDIR)/ <
foo
+ ar x lib$*.a gcl_recompile.o
+ touch -r lib$*.a gcl_recompile.o
$(RSYM): $(SPECIAL_RSYM) $(HDIR)/mdefs.h
$(CC) $(CFLAGS) -I$(HDIR) -I$(ODIR) -o $(RSYM) $(SPECIAL_RSYM)
@@ -123,6 +130,9 @@
$(HDIR)/mdefs.h: $(HDIR)/include.h
cat $(HDIR)/include.h | sed -e "/include/d" > $(HDIR)/mdefs.h
+gcl_recompile.o: ../lsp/gcl_recompile.o
+ cp $< $@
+
libgcl.a: $(OBJS) sys_gcl.o gmpfiles bfdfiles # plt_gcl.o
rm -rf $@
$(ARRS) $@ $(filter %.o,$^) $(shell find gmp bfd -name "*.o")
Index: unixport/sys_ansi_gcl.c
===================================================================
RCS file: /cvsroot/gcl/gcl/unixport/sys_ansi_gcl.c,v
retrieving revision 1.15
retrieving revision 1.16
diff -u -b -r1.15 -r1.16
--- unixport/sys_ansi_gcl.c 18 Apr 2006 04:38:06 -0000 1.15
+++ unixport/sys_ansi_gcl.c 5 Jun 2006 22:02:46 -0000 1.16
@@ -62,6 +62,7 @@
lsp_init("../lsp/gcl_export.lsp");
+ ar_init(gcl_callhash);
ar_init(gcl_defmacro);
ar_init(gcl_evalmacros);
ar_init(gcl_top);
@@ -174,8 +175,8 @@
ar_check_init(gcl_clcs_precom,no_init);
ar_check_init(gcl_clcs_macros,no_init);
ar_check_init(gcl_clcs_restart,no_init);
- ar_check_init(gcl_clcs_handler,no_init);
ar_check_init(gcl_clcs_debugger,no_init);
+ ar_check_init(gcl_clcs_handler,no_init);
ar_check_init(gcl_clcs_conditions,no_init);
ar_check_init(gcl_clcs_condition_definitions,no_init);
ar_check_init(gcl_clcs_kcl_cond,no_init);
@@ -184,6 +185,7 @@
#ifdef _WIN32
ar_check_init(gcl_win32,no_init);
#endif
+ ar_check_init(gcl_recompile,no_init);
}
static int ngazonk;
Index: unixport/sys_gcl.c
===================================================================
RCS file: /cvsroot/gcl/gcl/unixport/sys_gcl.c,v
retrieving revision 1.23
retrieving revision 1.24
diff -u -b -r1.23 -r1.24
--- unixport/sys_gcl.c 18 Apr 2006 04:38:06 -0000 1.23
+++ unixport/sys_gcl.c 5 Jun 2006 22:02:46 -0000 1.24
@@ -61,7 +61,7 @@
build_symbol_table();
lsp_init("../lsp/gcl_export.lsp");
-
+ ar_init(gcl_callhash);
ar_init(gcl_defmacro);
ar_init(gcl_evalmacros);
ar_init(gcl_top);
@@ -135,6 +135,7 @@
ar_check_init(gcl_cmpvs,no_init);
ar_check_init(gcl_cmpwt,no_init);
ar_check_init(gcl_cmpmain,no_init);
+ ar_check_init(gcl_recompile,no_init);
}
Index: unixport/sys_mod_gcl.c
===================================================================
RCS file: /cvsroot/gcl/gcl/unixport/sys_mod_gcl.c,v
retrieving revision 1.10
retrieving revision 1.11
diff -u -b -r1.10 -r1.11
--- unixport/sys_mod_gcl.c 18 Apr 2006 04:38:06 -0000 1.10
+++ unixport/sys_mod_gcl.c 5 Jun 2006 22:02:46 -0000 1.11
@@ -62,6 +62,7 @@
lsp_init("../lsp/gcl_export.lsp");
+ ar_init(gcl_callhash);
ar_init(gcl_defmacro);
ar_init(gcl_evalmacros);
ar_init(gcl_top);
@@ -139,6 +140,7 @@
#ifdef _WIN32
ar_check_init(gcl_win32,no_init);
#endif
+ ar_check_init(gcl_recompile,no_init);
}
Index: unixport/sys_pcl_gcl.c
===================================================================
RCS file: /cvsroot/gcl/gcl/unixport/sys_pcl_gcl.c,v
retrieving revision 1.14
retrieving revision 1.15
diff -u -b -r1.14 -r1.15
--- unixport/sys_pcl_gcl.c 18 Apr 2006 04:38:06 -0000 1.14
+++ unixport/sys_pcl_gcl.c 5 Jun 2006 22:02:46 -0000 1.15
@@ -62,6 +62,7 @@
lsp_init("../lsp/gcl_export.lsp");
+ ar_init(gcl_callhash);
ar_init(gcl_defmacro);
ar_init(gcl_evalmacros);
ar_init(gcl_top);
@@ -177,6 +178,7 @@
#ifdef _WIN32
ar_check_init(gcl_win32,no_init);
#endif
+ ar_check_init(gcl_recompile,no_init);
}
Index: unixport/sys_pre_gcl.c
===================================================================
RCS file: /cvsroot/gcl/gcl/unixport/sys_pre_gcl.c,v
retrieving revision 1.10
retrieving revision 1.11
diff -u -b -r1.10 -r1.11
--- unixport/sys_pre_gcl.c 18 Apr 2006 04:38:06 -0000 1.10
+++ unixport/sys_pre_gcl.c 5 Jun 2006 22:02:46 -0000 1.11
@@ -62,6 +62,8 @@
lsp_init("../lsp/gcl_export.lsp");
+ lsp_init("../lsp/gcl_callhash.lsp");
+
lsp_init("../lsp/gcl_defmacro.lsp");
lsp_init("../lsp/gcl_evalmacros.lsp");
lsp_init("../lsp/gcl_top.lsp");
@@ -78,9 +80,9 @@
if (type_of(no_init)!=t_symbol)
error("Supplied no_init is not of type symbol\n");
+ lsp_init("../lsp/gcl_predlib.lsp");
lsp_init("../lsp/gcl_listlib.lsp");
lsp_init("../lsp/gcl_mislib.lsp");
- lsp_init("../lsp/gcl_predlib.lsp");
lsp_init("../lsp/gcl_setf.lsp");
lsp_init("../lsp/gcl_arraylib.lsp");
Index: lsp/gcl_callhash.lsp
===================================================================
RCS file: lsp/gcl_callhash.lsp
diff -N lsp/gcl_callhash.lsp
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ lsp/gcl_callhash.lsp 5 Jun 2006 22:02:45 -0000 1.1
@@ -0,0 +1,173 @@
+;; -*-Lisp-*-
+(in-package 'si)
+
+(*make-special '*pahl*)
+(*make-special '*boot*)
+(eval-when (load eval)
+ (setq *pahl* nil)
+ (setq *boot* nil))
+
+(export '(function-lambda-expression))
+
+(defun add-hash (fn sig callees src)
+ (cond ((not (eq *boot* t))
+ (setq *pahl* (cons `(add-hash ',fn ',sig ',callees ,src) *pahl*))
+ (unless (or (not (fboundp 'make-s-data)) (not (let ((s (find-symbol
"FIND"))) (and s (fboundp s)))) *boot*)
+ (setq *boot* 'add-hash)
+ (let ((*package* (find-package "SI")))
+ (defstruct (call (:copier copy-call)
+ (:predicate call-p)
+ (:constructor make-call))
+ sig callees callers src)
+ (defvar *call-hash-table* (make-hash-table :test 'eq))
+ (defvar *needs-recompile* (make-array 10 :fill-pointer 0
:adjustable t))
+ (defvar *ach* (make-hash-table :test 'eq))
+ (setq *boot* t)
+ (mapc 'eval (nreverse *pahl*))
+ (setq *pahl* nil))))
+ ((let ((h (or (gethash fn *call-hash-table*)
+ (setf (gethash fn *call-hash-table*) (make-call :sig
sig)))))
+ (when sig (proclaim `(ftype (function ,@sig) ,fn)))
+ (when (and sig (not (equal sig (call-sig h))))
+ (dolist (l (call-callers h))
+ (unless (eq l fn)
+ (add-recompile l fn (call-sig h) sig)))
+ (setf (call-sig h) sig))
+ (when src (setf (call-src h) src))
+ (let (ar)
+ (dolist (l callees (unless ar (when sig (remove-recompile fn))))
+ (pushnew (car l) (call-callees h))
+ (let ((h (or (gethash (car l) *call-hash-table*)
+ (setf (gethash (car l) *call-hash-table*)
(make-call :sig (cdr l) :callers (list fn))))))
+ (pushnew fn (call-callers h))
+ (unless (or (eq fn (car l)) (equal (cdr l) (call-sig h)))
+ (add-recompile fn (car l) (cdr l) (call-sig h))
+ (setq ar t)))))))))
+
+(defun clear-compiler-properties (sym code)
+ (cond ((not (eq *boot* t))
+ (push `(clear-compiler-properties ',sym nil) *pahl*))
+ ((let ((h (or (gethash sym *call-hash-table*)
+ (setf (gethash sym *call-hash-table*) (make-call)))))
+ (dolist (l (call-callees h))
+ (let ((l (gethash l *call-hash-table*)))
+ (setf (call-callers l) (delete sym (call-callers l)))))
+ (let (new)
+ (maphash (lambda (x y)
+ (when (and (fboundp x) (eq (symbol-function x) code)
(call-src y))
+ (setq new x))) *call-hash-table*)
+ (cond (new
+ (let ((nr (find new *needs-recompile* :key 'car)))
+ (when nr (add-recompile sym (cadr nr) (caddr nr) (cadddr
nr))))
+ (setq new (gethash new *call-hash-table*))
+ (let ((ns (call-sig new)))
+ (unless (equal ns (call-sig h))
+ (dolist (l (call-callers h))
+ (add-recompile l sym (call-sig h) ns)))
+ (setf (call-sig h) ns)
+ (proclaim `(ftype (function ,@ns) ,sym)))
+ (dolist (l (call-callees new))
+ (pushnew sym (call-callers (gethash l
*call-hash-table*))))
+ (setf (call-callees h) (call-callees new) (call-src h)
(call-src new)))
+ ((setf (call-callees h) nil (call-src h) nil))))))))
+
+(defun add-recompile (fn why assumed-sig actual-sig)(when (and (eq
(symbol-package why) (find-package "COMPILER")) (equal (symbol-name why)
"VAR-KIND")) (break "~s ~s ~s ~s~%" fn why assumed-sig actual-sig))
+ (unless (find fn *needs-recompile* :key 'car)
+; (format t "add-recompile ~s ~s ~s ~s~%" fn why assumed-sig actual-sig)
+ (vector-push-extend (list fn why assumed-sig actual-sig) *needs-recompile*)
+ nil))
+
+(defun remove-recompile (fn)
+ (let ((p (position fn *needs-recompile* :key 'car)))
+ (when p
+; (format t "removing recompile of ~s~%" fn)
+ (decf (fill-pointer *needs-recompile*))
+ (do ((i p (1+ i))) ((= i (length *needs-recompile*)))
+ (setf (aref *needs-recompile* i) (aref *needs-recompile* (1+ i)))))))
+
+(defun clr-call nil
+ (clrhash *call-hash-table*)
+ (setf (fill-pointer *needs-recompile*) 0))
+
+
+(defun all-callees (x y)
+ (let ((z (gethash x *ach*)))
+ (if z (union z y)
+ (let ((z (call-callees (gethash x *call-hash-table*))))
+ (do ((l (set-difference z y) (cdr l))
+ (r (union z y) (all-callees (car l) r)))
+ ((endp l)
+ (unless (intersection z y) (setf (gethash x *ach*) (set-difference
r y)))
+ r))))))
+
+; (let* ((z (call-callees (gethash x *call-hash-table*)))
+; (r (union z y))
+; (q (dolist (l (set-difference z y) r)
+; (setq r (all-callees l r)))))
+; (unless (intersection z y) (setf (gethash x *ach*) (set-difference q
y)))
+; q))))
+
+(defun function-lambda-expression (x)
+ (if (typep x 'interpreted-function)
+ (let* ((x (si::interpreted-function-lambda x)))
+ (case (car x)
+ (lambda (values x nil nil))
+ (lambda-block (values (cons 'lambda (cddr x)) nil (cadr x)))
+ (lambda-closure (values (cons 'lambda (cddr (cddr x))) (not (not
(cadr x))) nil))
+ (lambda-block-closure (values (cons 'lambda (cdr (cddr (cddr
x)))) (not (not (cadr x))) (fifth x)))
+ (otherwise (values nil t nil))))
+ (values nil t nil)))
+
+(defun function-src (sym)
+ (or
+ (let* ((h (gethash sym *call-hash-table*))
+ (fas (when h (call-src h))))
+ (when fas
+ (let* ((ss (open-fasd (make-string-input-stream fas) :input 'eof nil))
+ (out (read-fasd-top ss)))
+ (close-fasd ss)
+ out)))
+ (and (fboundp sym) (typep (symbol-function sym) 'interpreted-function)
(function-lambda-expression (symbol-function sym)))))
+
+(defun do-recompile (&optional (pn "/tmp/recompile.lsp" pnp))
+ (unless (or *disable-recompile* (= 0 (length *needs-recompile*)))
+ (let ((*disable-recompile* t))
+ (clrhash *ach*)
+ (setq *needs-recompile*
+ (sort *needs-recompile* ;FIXME
+ (lambda (x y)
+ (member (car x) (all-callees (car y) nil)))))
+ (maphash (lambda (x y) (when (call-sig y) (proclaim `(ftype (function
,@(call-sig y)) ,x)))) *call-hash-table*)
+ (unless pnp (delete-file pn))
+ (map nil (lambda (fn)
+ (format t "Callee ~s sigchange ~s to ~s, recompiling ~s~%"
+ (cadr fn) (caddr fn) (cadddr fn) (car fn)))
*needs-recompile*)
+ (with-open-file
+ (s pn :direction :output :if-exists :append :if-does-not-exist :create)
+ (let ((*print-radix* nil)
+ (*print-base* 10)
+ (*print-circle* t)
+ (*print-pretty* nil)
+ (*print-level* nil)
+ (*print-length* nil)
+ (*print-case* :downcase)
+ (*print-gensym* t)
+ (*print-array* t)
+ (si::*print-package* t)
+ (si::*print-structure* t))
+ (dotimes (i (length *needs-recompile*))
+ (let* ((fn (car (aref *needs-recompile* i)))
+ (src (function-src fn)))
+ (if src (prin1 `(defun ,fn ,@(cdr src)) s)
+ (remove-recompile fn))))))
+ (load (compile-file pn :system-p t :c-file t :h-file t :data-file t)))
+ (do-recompile pn)))
+
+;FIXME!!!
+(defun is-eq-test-item-list (&rest r)
+ (format t "Should never be called ~s~%" r))
+
+(defun cmp-vec-length (x)
+ (declare (vector x))
+ (if (array-has-fill-pointer-p x) (fill-pointer x) (array-dimension x 0)))
+
| [Prev in Thread] |
Current Thread |
[Next in Thread] |
- [Gcl-commits] gcl debianchangelog clcs/gcl_clcs_condition_def...,
Camm Maguire <=