gcl.git - GNU Common Lisp

diff --git a/gcl/cmpnew/gcl_cmpcall.lsp b/gcl/cmpnew/gcl_cmpcall.lsp
index 536de1652..d7c25809a 100755
--- a/gcl/cmpnew/gcl_cmpcall.lsp
+++ b/gcl/cmpnew/gcl_cmpcall.lsp

@@ -326,7 +326,7 @@

(defun add-fast-link (fname type args)

- (let (link link-info (n (add-symbol fname)) vararg)

+ (let (link link-info (n (add-object2 (add-symbol fname))) vararg)

(cond (type

;;should do some args checking in that case too.

(let* (link-string tem argtypes

@@ -409,10 +409,10 @@

(cond

((null type)

(wt-nl1 "static void LnkT"

- num "(){ call_or_link(" (vv-str num) ",(void **)(void *)&Lnk" num");}"))

+ num "(){ call_or_link(VV[" num "],(void **)(void *)&Lnk" num");}"))

((eql type 'proclaimed-closure)

(wt-nl1 "static void LnkT" num

- "(ptr) object *ptr;{ call_or_link_closure(" (vv-str num) ",(void **)(void *)&Lnk" num",(void **)(void *)&Lclptr" num");}"))

+ "(ptr) object *ptr;{ call_or_link_closure(VV[" num "],(void **)(void *)&Lnk" num",(void **)(void *)&Lclptr" num");}"))

(t

;;change later to include above.

;;(setq type (cdr (assoc type '((t . "object")(:btpr . "bptr")))))

diff --git a/gcl/cmpnew/gcl_cmpenv.lsp b/gcl/cmpnew/gcl_cmpenv.lsp
index 15ce5fe24..158e57370 100755
--- a/gcl/cmpnew/gcl_cmpenv.lsp
+++ b/gcl/cmpnew/gcl_cmpenv.lsp

@@ -39,7 +39,8 @@

(setq *next-vv* -1)

(setq *next-cfun* 0)

(setq *last-label* 0)

- (setq *objects* nil)

+ (clrhash *objects*)

+ (clrhash *rev-objects*)

(setq *hash-eq* nil)

(setq *constants* nil)

(setq *local-funs* nil)

@@ -68,12 +69,17 @@

(defmacro next-cfun () '(incf *next-cfun*))

-(defun add-symbol (symbol)

- (let ((x (assoc symbol *objects*)))

- (cond (x (cadr x))

- (t (push-data-incf symbol)

- (push (list symbol *next-vv*) *objects*)

- *next-vv*))))

+(defun add-symbol (symbol) (add-object symbol))

+

+(defun add-object2 (object)

+ (let* ((init (when (si::contains-sharp-comma object)

+ (if (when (consp object) (eq (car object) 'si::|#,|))

+ (cdr object) (si::string-to-object (wt-to-string object)))))

+ (object (if (when (consp init) (eq (car init) 'si::nani)) (si::nani (cadr init)) object)))

+ (cond ((gethash object *objects*))

+ ((push-data-incf (unless init object))

+ (when init (add-init `(si::setvv ,*next-vv* ,init)))

+ (setf (gethash *next-vv* *rev-objects*) object (gethash object *objects*) *next-vv*)))))

;; Write to a string with all the *print-.. levels bound appropriately.

(defun wt-to-string (x &aux

@@ -82,47 +88,16 @@

(wt-data1 x)

(get-output-stream-string *compiler-output-data*))

-(defun add-object (object &aux x)

- ;;; Used only during Pass 1.

- (cond ((si:contains-sharp-comma object)

- ;;; SI:CONTAINS-SHARP-COMMA returns T iff OBJECT

- ;;; contains a sharp comma OR a structure.

- ;; there will be an eval and we want the eval to happen

- (cond ((and

- (consp object)

- (eq (car object) 'si::|#,|)

- (not (si:contains-sharp-comma (cdr object))))

- (setq object (cdr object)))

- (t (setq object `(si::string-to-object

- ,(wt-to-string object)))))

- (push-data-incf nil)

- (push (list *next-vv* object) *sharp-commas*)

- *next-vv*)

- ((setq x (assoc object *objects*))

- (cadr x))

- ((typep object 'compiled-function)

- (push-data-incf nil)

- (push (list *next-vv* `(function

- ,(or (si::compiled-function-name

- object)

- (cmperr "Can't dump un named compiled funs")

- )))

- *sharp-commas*)

- *next-vv*

- )

- (t

- (push-data-incf object)

- (push (list object *next-vv*) *objects*)

- *next-vv*)))

-

-(defun add-constant (symbol &aux x)

- ;;; Used only during Pass 1.

- (cond ((setq x (assoc symbol *constants*))

- (cadr x))

- (t (push-data-incf nil)

- (push (list *next-vv* symbol) *sharp-commas*)

- (push (list symbol *next-vv*) *constants*)

- *next-vv*)))

+(defun ltvp (val)

+ (when (consp val) (eq (car val) 'si::|#,|)))

+

+(defun add-object (object)

+ (cond ((ltvp object) object)

+ ((and *compiler-compile* (not *keep-gaz*)) (cons 'si::|#,| `(si::nani ,(si::address object))))

+ (object)))

+

+(defun add-constant (symbol)

+ (add-object (cons 'si::|#,| symbol)))

(defmacro next-cvar () '(incf *next-cvar*))

(defmacro next-cmacro () '(incf *next-cmacro*))

diff --git a/gcl/cmpnew/gcl_cmpfun.lsp b/gcl/cmpnew/gcl_cmpfun.lsp
index e898b1d27..fb7278e33 100755
--- a/gcl/cmpnew/gcl_cmpfun.lsp
+++ b/gcl/cmpnew/gcl_cmpfun.lsp

@@ -912,13 +912,8 @@

(c1expr `(let ((,s ,(car args)))

(sublis1 ,s ,(second args) ',test))))))

-

(defun sublis1-inline (a b c)

- (let ((tst (or (car (find (cadr c) *objects* :key 'cadr))

- (let ((v (member (cadr c) *top-level-forms* :key 'cadr)))

- (and v

- (eq (caar v) 'sharp-comma)

- (cmp-eval (caddar v)))))))

+ (let ((tst (cadr c)))

(or (member tst '(eq equal eql)) (error "bad test"))

(wt "(check_alist(" a "),sublis1("a "," b "," (format nil "&o~(~a~)))" tst))))

diff --git a/gcl/cmpnew/gcl_cmplam.lsp b/gcl/cmpnew/gcl_cmplam.lsp
index abcfa240e..6a70bd64e 100755
--- a/gcl/cmpnew/gcl_cmplam.lsp
+++ b/gcl/cmpnew/gcl_cmplam.lsp

@@ -588,7 +588,7 @@

(if rest (wt ",TRUE,") (wt ",FALSE,"))

(if allow-other-keys (wt "TRUE,") (wt "FALSE,"))

(wt (length keywords))

- (dolist** (kwd keywords) (wt ",VV[" (add-symbol (car kwd)) "]"))

+ (dolist** (kwd keywords) (wt "," (vv-str (add-symbol (car kwd)))))

(wt ");")

;;; Bind required parameters.

diff --git a/gcl/cmpnew/gcl_cmploc.lsp b/gcl/cmpnew/gcl_cmploc.lsp
index 625d74e91..ac761125a 100755
--- a/gcl/cmpnew/gcl_cmploc.lsp
+++ b/gcl/cmpnew/gcl_cmploc.lsp

@@ -178,7 +178,7 @@

(if type (wt "/* " (symbol-name type) " */"))

(wt "V" cvar))

-(defun vv-str (vv) (si::string-concatenate "((object)VV[" (write-to-string vv) "])"))

+(defun vv-str (vv) (let ((vv (add-object2 vv))) (si::string-concatenate "((object)VV[" (write-to-string vv) "])")))

(defun wt-vv (vv) (wt (vv-str vv)))

diff --git a/gcl/cmpnew/gcl_cmpspecial.lsp b/gcl/cmpnew/gcl_cmpspecial.lsp
index afa33c9cd..7c7d04357 100755
--- a/gcl/cmpnew/gcl_cmpspecial.lsp
+++ b/gcl/cmpnew/gcl_cmpspecial.lsp

@@ -132,12 +132,9 @@

(push fun *closures*)

(cond (*clink*

(unwind-exit (list 'make-cclosure (fun-cfun fun) *clink* (fun-name fun))))

- (t (push-data-incf nil)

- (add-init `(si::setvv ,*next-vv*

- (si::mc nil ,(add-address

- (c-function-name "&LC" (fun-cfun fun) (fun-name fun)))))

- t)

- (unwind-exit (list 'vv *next-vv*)))))

+ (t (unwind-exit (list 'vv (cons 'si::|#,|

+ `(si::mc nil ,(add-address

+ (c-function-name "&LC" (fun-cfun fun) (fun-name fun))))))))))

))

)

diff --git a/gcl/cmpnew/gcl_cmptop.lsp b/gcl/cmpnew/gcl_cmptop.lsp
index 80830f434..5bd93d0c0 100755
--- a/gcl/cmpnew/gcl_cmptop.lsp
+++ b/gcl/cmpnew/gcl_cmptop.lsp

@@ -21,7 +21,9 @@

(in-package 'compiler)

-(defvar *objects* nil)

+(defvar *objects* (make-hash-table :test 'eq))

+(defvar *rev-objects* (make-hash-table :test 'eql))

+;(defvar *objects* nil)

(defvar *constants* nil)

(defvar *sharp-commas* nil)

(defvar *function-links* nil)

@@ -377,7 +379,7 @@

(wt-data-file)

-

+; (break "f")

(dolist (x *function-links* )

(let ((num (second x))

(type (third x))

@@ -1043,9 +1045,10 @@

((and (eq (setq tem (third (car v))) nil))

(wt "-2"))

((and (consp tem) (eq (car tem) 'vv))

- (wt (second tem) ))

+ (wt (add-object2 (add-object (second tem))) ))

((and (consp tem) (eq (car tem) 'fixnum-value))

- (wt (add-object(third tem)) ))

+; (print (setq ttem tem)) (break)

+ (wt (add-object2 (add-object (third tem))) ))

(t (baboon)))

(if (cdr v) (wt ",")))

@@ -1068,7 +1071,8 @@

;; We write this list backwards for convenience

;; in stepping through it in parse_key

(wt "(void *)")

- (wt (add-symbol (caar v)) )

+; (print (setq ss v))(break "h")

+ (wt (add-object2 (add-symbol (caar v))))

(if (cdr v) (wt ",")))

(wt "}"))

(wt "};")

@@ -1425,7 +1429,7 @@

nil

))))

-(defun t2ordinary (form)

+(defun t3ordinary (form)

(cond ((atom form))

((constantp form))

(t (add-init form ))))

@@ -1796,7 +1800,7 @@

(when (eq (car form) 'location)

(when (listp (caddr form))

(when (eq 'vv (caaddr form))

- (let ((s (car (rassoc (cadr (caddr form)) *objects* :key 'car))))

+ (let ((s (gethash (cadr (caddr form)) *rev-objects*)))

(when s `(defun ,s)))))))

(defun c1fset (args)