gcl.git - GNU Common Lisp

diff --git a/gcl/lsp/gcl_predlib.lsp b/gcl/lsp/gcl_predlib.lsp
index 87d8dcbb7..40916dac7 100755
--- a/gcl/lsp/gcl_predlib.lsp
+++ b/gcl/lsp/gcl_predlib.lsp

@@ -26,6 +26,10 @@

(export '(int void static

non-standard-generic-function

+ non-standard-generic-compiled-function

+ non-standard-generic-interpreted-function

+ standard-generic-compiled-function

+ standard-generic-interpreted-function

non-logical-pathname

non-standard-base-char true gsym

std-instance

@@ -433,10 +437,11 @@

(deftype real (&optional (low '*) (high '*)) `(or (rational ,low ,high) (float ,low ,high)))

(deftype number () `(or real complex))

(deftype atom () `(not cons))

-(deftype function (&rest r) (declare (ignore r)) `(or standard-generic-function non-standard-generic-function))

-;; (defun compiled-function-p (fun) (when (typep fun 'function) (typep (caddr (c-function-plist fun)) 'string)))

-;; (deftype compiled-function nil `(and function (satisfies compiled-function-p)))

-(deftype compiled-function nil 'function);FIXME

+(deftype compiled-function nil `(or standard-generic-compiled-function non-standard-generic-compiled-function))

+(deftype interpreted-function nil `(or standard-generic-interpreted-function non-standard-generic-interpreted-function))

+(deftype function (&rest r) (declare (ignore r)) `(or compiled-function interpreted-function))

+(deftype standard-generic-function nil `(or standard-generic-compiled-function standard-generic-interpreted-function))

+(deftype non-standard-generic-function nil `(and function (not standard-generic-function)))

;(deftype integer (&optional (low '*) (high '*)) `(integer ,low ,high))

(deftype ratio (&optional (low '*) (high '*)) `(ratio ,low ,high))

@@ -619,8 +624,11 @@

readtable

hash-table-eq hash-table-eql hash-table-equal hash-table-equalp

random-state std-instance structure

- non-standard-generic-function

- standard-generic-function spice

+ non-standard-generic-interpreted-function

+ non-standard-generic-compiled-function

+ standard-generic-interpreted-function

+ standard-generic-compiled-function

+ spice

))

@@ -648,7 +656,8 @@

(cons . cons-op)

; (standard-object . standard-op)

(std-instance . standard-op)

- (standard-generic-function . standard-op)

+ (standard-generic-compiled-function . standard-op)

+ (standard-generic-interpreted-function . standard-op)

(structure . structure-op)

,@(mapcar (lambda (x) `(,(cdr x) . complex-op)) +complex-type-alist+)

,@(mapcar (lambda (x) `(,(cdr x) . array-op)) +array-type-alist+)

@@ -658,7 +667,8 @@

(cons . cons-recon)

; (standard-object . standard-recon)

(std-instance . standard-recon)

- (standard-generic-function . standard-recon)

+ (standard-generic-compiled-function . standard-recon)

+ (standard-generic-interpreted-function . standard-recon)

(structure . structure-recon)

,@(mapcar (lambda (x) `(,(cdr x) . complex-recon)) +complex-type-alist+)

,@(mapcar (lambda (x) `(,(cdr x) . array-recon)) +array-type-alist+)

@@ -669,7 +679,8 @@

(cons . cons-load)

; (standard-object . standard-load)

(std-instance . standard-load)

- (standard-generic-function . standard-load)

+ (standard-generic-compiled-function . standard-load)

+ (standard-generic-interpreted-function . standard-load)

(structure . structure-load)

(array . array-load)

; (simple-array . array-load)

@@ -1521,9 +1532,12 @@

((setq tem (coerce-to-standard-class (car type)))

(let ((s (load-time-value nil))(q (load-time-value nil)))

(setq s (or s (coerce-to-standard-class 'generic-function)) q (or q (si-class-precedence-list s)))

- (cond ((member s (si-class-precedence-list tem)) (ntp-ld ntp (list 'standard-generic-function (if (eq s tem) t tem))))

+ (cond ((member s (si-class-precedence-list tem))

+ (ntp-ld ntp (list 'standard-generic-compiled-function (if (eq s tem) t tem)))

+ (ntp-ld ntp (list 'standard-generic-interpreted-function (if (eq s tem) t tem))))

((member tem q)

- (ntp-ld ntp (list 'standard-generic-function t))

+ (ntp-ld ntp (list 'standard-generic-interpreted-function t))

+ (ntp-ld ntp (list 'standard-generic-compiled-function t))

(ntp-ld ntp (list 'std-instance t)))

((ntp-ld ntp (list 'std-instance tem))))))

((and (symbolp (car type)) (setq tem (get (car type) 's-data)))

diff --git a/gcl/lsp/gcl_sc.lsp b/gcl/lsp/gcl_sc.lsp
index de28d8e29..e71501e6a 100644
--- a/gcl/lsp/gcl_sc.lsp
+++ b/gcl/lsp/gcl_sc.lsp

@@ -423,8 +423,8 @@

(defun functionp (x)

(typecase x (function t)))

-(defun compiled-function-p (x)

- (typecase x (function (typep (caddr (c-function-plist x)) 'string))))

+(defun compiled-function-p (x)

+ (typecase x (compiled-function t)))

(defun stringp (x)

(typecase

diff --git a/gcl/lsp/gcl_type.lsp b/gcl/lsp/gcl_type.lsp
index 9dcd57291..7b4444aec 100644
--- a/gcl/lsp/gcl_type.lsp
+++ b/gcl/lsp/gcl_type.lsp

@@ -268,8 +268,10 @@

(string-output-stream (make-string-output-stream));FIXME user defined, socket

(random-state (make-random-state))

(readtable (standard-readtable))

- (non-standard-generic-function (function eq))

- (standard-generic-function (set-d-tt 1 (lambda nil nil)))

+ (non-standard-generic-compiled-function (function eq))

+ (non-standard-generic-interpreted-function (set-d-tt 2 (lambda nil nil)))

+ (standard-generic-compiled-function (set-d-tt 1 (lambda nil nil)))

+ (standard-generic-interpreted-function (set-d-tt 3 (lambda nil nil)))

,@(mapcar (lambda (x) `(,(cadr x) (make-vector ',(car x) 1 nil nil nil 0 nil nil))) +vtps+)

,@(mapcar (lambda (x) `(,(cadr x) (make-array1 ',(car x) nil nil nil 0 '(1 1) nil))) +atps+)

(spice (alloc-spice))

diff --git a/gcl/o/makefun.c b/gcl/o/makefun.c
index 8e9dce5b4..989e6fa5c 100755
--- a/gcl/o/makefun.c
+++ b/gcl/o/makefun.c

@@ -39,9 +39,6 @@ object

make_fun(void *addr,object data,object call,object env,ufixnum argd,ufixnum sizes) {

object x;

- /* ufixnum n; */

-

- /* for (n=0,x=env;x!=Cnil;x=x->c.c_cdr,n++); */

x=alloc_object(t_function);

x->fun.fun_self=addr;

@@ -54,25 +51,10 @@ make_fun(void *addr,object data,object call,object env,ufixnum argd,ufixnum size

x->fun.fun_vv =POP_BITS(sizes,1);

x->fun.fun_env=def_env;

- FFN(fSset_function_environment)(x,env);

-

- /* if (n++) { */

-

- /* object *p; */

+ if ((void *)x->fun.fun_self==(void *)FFN(fSeval_src))

+ x->d.tt=2;

- /* { */

- /* BEGIN_NO_INTERRUPT; */

- /* p=(object *)alloc_relblock(n*sizeof(object)); */

- /* END_NO_INTERRUPT; */

- /* } */

-

- /* *p++=(object)n; */

- /* x->fun.fun_env=p; */

-

- /* for (;env!=Cnil;env=env->c.c_cdr) */

- /* *p++=env; */

-

- /* } */

+ FFN(fSset_function_environment)(x,env);

return x;

diff --git a/gcl/pcl/gcl_pcl_defs.lisp b/gcl/pcl/gcl_pcl_defs.lisp
index 75808e8ea..49ad6b08f 100644
--- a/gcl/pcl/gcl_pcl_defs.lisp
+++ b/gcl/pcl/gcl_pcl_defs.lisp

@@ -425,8 +425,7 @@

;; better. Note that for most ports, providing this definition

;; should just speed up class definition. It shouldn't have an

;; effect on performance of most user code.

- (progn ;(break "foo ~a ~a~%" name predicate)

- (eval `(deftype ,name () '(satisfies ,predicate)))))

+ (unless (get name 'si::deftype-definition) (eval `(deftype ,name () '(satisfies ,predicate)))))

(defun make-type-predicate-name (name &optional kind)

(if (symbol-package name)

diff --git a/gcl/pcl/gcl_pcl_impl_low.lisp b/gcl/pcl/gcl_pcl_impl_low.lisp
index ca9d86227..793cffc30 100644
--- a/gcl/pcl/gcl_pcl_impl_low.lisp
+++ b/gcl/pcl/gcl_pcl_impl_low.lisp

@@ -10,7 +10,7 @@

(defun %%allocate-instance--class (&aux wrapper slots)

(let ((i (system:make-structure 'std-instance wrapper slots)))

- (c-set-t-tt i 1)

+ (c-set-t-tt i (logior 1 (c-t-tt i)))

i))

(import '(si::memq) 'pcl)

@@ -61,7 +61,7 @@

(let ((fin (allocate-funcallable-instance-2))

(env (make-list funcallable-instance-closure-size :initial-element nil)))

(si::set-function-environment fin env)

- (c-set-t-tt fin 1)

+ (c-set-t-tt fin (logior 1 (c-t-tt fin)))

fin))

(defun funcallable-instance-p (x) (typep x 'standard-generic-function))