Re: [Fwd: Re: [Gcl-devel] Recent ansi fixes]

[Camm Maguire]

Greetings!  

"Paul F. Dietz" <address@hidden> writes:

> (forgot to cc this)
> 
> >>gcl apparently has to print things when compiling, which means it
> >>inappropriately rejects unprintable objects in literal constants.
> >>
> >>What you need to do, I think, is print some object that is a pointer
> >>back to the address of the unprintable object in the lisp's memory.
> >>When the reader reads this, it should be converted back to a reference
> >>to that object.  LOAD-TIME-VALUE might be useful here?
> > Does this mean I can make up my own pseudo syntax, maybe using
> > #something-not-in-use, and instruct the reader to parse this
> > appropriately? Which compile bugs are you referring to below?
> 
> This pseudosyntax would just be for the internal printing needed
> to implement COMPILE.  It needn't be externally visible.
> 
> The compiler bugs are in ansi-tests/compile.lsp, in the tests
> that check if COMPILE coalesces literal constants (note that it
> can't, unlike the file compiler; see section 3.2.4, paragraph 1.)
> 

OK, I have a beginning of a fix, and would like some feedback from the
gurus:

=============================================================================
Index: gcl_cmpmain.lsp
===================================================================
RCS file: /cvsroot/gcl/gcl/cmpnew/gcl_cmpmain.lsp,v
retrieving revision 1.4
diff -u -r1.4 gcl_cmpmain.lsp
--- gcl_cmpmain.lsp     10 Oct 2003 05:14:03 -0000      1.4
+++ gcl_cmpmain.lsp     24 Oct 2003 22:20:43 -0000
@@ -405,8 +405,10 @@
     (wt-data1 form)  ;; this binds all the print stuff
     ))
 
+(defmacro compile (name &optional def)
+  `(compile-internal ,name (do-compile-literal-objects ,def)))
 
-(defun compile (name &optional def &aux tem gaz (*default-pathname-defaults* 
#"."))
+(defun compile-internal (name &optional def &aux tem gaz 
(*default-pathname-defaults* #"."))
 
   (cond ((not(symbolp name)) (error "Must be a name"))
        ((and (consp def)
@@ -424,7 +426,8 @@
        ((and (setq tem (symbol-function name))
              (consp tem))
         (let ((na (if (symbol-package name) name 'cmp-anon)))
-          (unless (and (fboundp 'si::init-cmp-anon) (or (si::init-cmp-anon) 
(fmakunbound 'si::init-cmp-anon)))
+          (unless (and (fboundp 'si::init-cmp-anon)
+                       (or (si::init-cmp-anon) (fmakunbound 
'si::init-cmp-anon)))
             (with-open-file
              (st (setq gaz (gazonk-name)) :direction :output)
              (prin1-cmp `(defun ,na ,@ (ecase (car tem)
Index: gcl_cmpeval.lsp
===================================================================
RCS file: /cvsroot/gcl/gcl/cmpnew/gcl_cmpeval.lsp,v
retrieving revision 1.3
diff -u -r1.3 gcl_cmpeval.lsp
--- gcl_cmpeval.lsp     10 Oct 2003 02:37:59 -0000      1.3
+++ gcl_cmpeval.lsp     24 Oct 2003 22:20:44 -0000
@@ -681,4 +681,90 @@
              (setq tem (get f 'si::struct-predicate)))
         (c1expr `(typep ,(car args) ',tem)))))
 
+;; The following code is added to prevent coalescing literal objects in 
(compile ...)
+;; CM 20031024
 
+(defvar *sym-list*)
+(defvar *new-form*)
+
+(defun add-to-sym-list-and-new-form (f)
+  (unless (member f *sym-list* :key #'cadadr)
+    (push `(list ',f (list 'si::nani (si::address ,f))) *sym-list*))
+  (push `',f *new-form*))
+
+(defun literal-to-be-quoted-p (form)
+  (when (consp form)
+    (let ((cdf (cadr form)))
+      (and (eq (car form) 'list)
+          (consp cdf)
+          (eq (car cdf) 'quote)
+          (eq (cadr cdf) 'quote)))))
+  
+(defun compile-literal-objects (form)
+  (let (*new-form*)
+    (dolist (f form)
+      (cond ((literal-to-be-quoted-p f)
+            (add-to-sym-list-and-new-form (caddr f)))
+           ((consp f)
+            (push (if (eq (car f) 'quote) f (compile-literal-objects f)) 
*new-form*))
+           ((or (not (symbolp f)) (fboundp f) (constantp f))
+            (push f *new-form*))
+           (t
+            (add-to-sym-list-and-new-form f))))
+      (nreverse *new-form*)))
+
+(defmacro do-compile-literal-objects (form) 
+
+  (let (new-form-head
+    (when (and (consp form) (eq (car form) 'list))
+      (let ((cdf (cadr form)))
+       (when (and (consp cdf)
+                  (eq (car cdf) 'quote))
+         (let* ((lt (cadr cdf))
+                (ltt (car (member lt '(lambda lambda-block)))))
+           (when ltt
+             (push (pop form) new-form-head)
+             (push (pop form) new-form-head)
+             (push (pop form) new-form-head)
+             (when (eq ltt 'lambda-block)
+               (push (pop form) new-form-head)))))))
+
+    (if new-form-head
+       (let* (*sym-list*
+              (new-form (compile-literal-objects form)))
+         (append (nreverse new-form-head)
+                 `((list 'let (list ,@*sym-list*)
+                              ,@new-form))))
+      form)))
=============================================================================

This macroexpands "literal-list-lambda" code on the compile command
line like:

(let ((x 2)) 
        (format t "~S~%" (si::address x))
        (macroexpand '(compiler::do-compile-literal-objects 
                (list 'lambda nil (list 'eq x x)))))

139656144
(LIST 'LAMBDA NIL
      (LIST 'LET
            (LIST (LIST 'X (LIST 'SYSTEM:NANI (SYSTEM:ADDRESS X))))
            (LIST 'EQ 'X 'X)))

which then evals to

(let ((x 2)) (LIST 'LAMBDA NIL
      (LIST 'LET
            (LIST (LIST 'X (LIST 'SYSTEM:NANI (SYSTEM:ADDRESS X))))
            (LIST 'EQ 'X 'X))))

(LAMBDA () (LET ((X (SYSTEM:NANI 139668432))) (EQ X X)))

The strategy here is (obviously) to make use of GCL's si::address
function (to get the address of an object), and the si::nani function,
(to get the object at an address), and to wrap the lambda body in a
let setting the variable to its outer value, while quoting it in the
form to protect if from eval.

This fixes compile.5678, but not the.12 (yet?), as I don't know how to
get at the lambda function definition in a macro in a call like

(LET ((CL-TEST::LEXPR
                (LIST 'LAMBDA NIL
                      (LIST* 'AND
                             (LOOP
                               CL-TEST::FOR
                               CL-TEST::E
                               CL-TEST::IN
                               CL-TEST::*MINI-UNIVERSE*
                               CL-TEST::FOR
                               TYPE
                               =
                               (TYPE-OF CL-TEST::E)
                               CL-TEST::COLLECT
                               (LIST 'CL-TEST::EQLT
                                     (LIST 'QUOTE CL-TEST::E)
                                     (LIST 'THE TYPE
                                      (LIST 'QUOTE CL-TEST::E))))))))
        (FUNCALL (COMPILE NIL CL-TEST::LEXPR)))

Inside the macro, lexpr is not fboundp nor boundp :-(.

I'm also not 100% sure on the logic of what constitutes an
'externalizable' (?) object. (See logic in compile-literal-objects). 

Enlightenment, suggestions, and catcalls most welcome!

Take care,


>       Paul
> 
> 
> ----------
> 
> 
> _______________________________________________
> Gcl-devel mailing list
> address@hidden
> http://mail.gnu.org/mailman/listinfo/gcl-devel
> 

-- 
Camm Maguire                                            address@hidden
==========================================================================
"The earth is but one country, and mankind its citizens."  --  Baha'u'llah