r454 - trunk/tools/cold

[rswindells at common-lisp.net]

Author: rswindells
Date: Sun Jun 12 18:47:19 2016
New Revision: 454

Log:
Fix up dummy float handling.

Add missing quote for forward-value-cell handling.

Modified:
   trunk/tools/cold/coldld.lisp
   trunk/tools/cold/coldut.lisp

Modified: trunk/tools/cold/coldld.lisp
==============================================================================
--- trunk/tools/cold/coldld.lisp	Sun Jun 12 18:12:41 2016	(r453)
+++ trunk/tools/cold/coldld.lisp	Sun Jun 12 18:47:19 2016	(r454)
@@ -321,13 +321,16 @@
 (defun m-fasl-op-float ()
   (q-fasl-op-float))
 
+;;; XXX fix this
 (defun m-fasl-op-float-float ()
   (prog (ans tmp)
     (setq ans (float 0))
-    (%p-dpb-offset (qfasl-next-nibble) #o1013 ans 0)
+    ;(%p-dpb-offset (qfasl-next-nibble) #o1013 ans 0)
+    (qfasl-next-nibble)
     (setq tmp (qfasl-next-nibble))
-    (%p-dpb-offset (lispm-ldb #o1010 tmp) #o0010 ans 0)
-    (%p-dpb-offset (lispm-dpb tmp #o2010 (qfasl-next-nibble)) #o0030 ans 1)
+    ;(%p-dpb-offset (lispm-ldb #o1010 tmp) #o0010 ans 0)
+    ;(%p-dpb-offset (lispm-dpb tmp #o2010 (qfasl-next-nibble)) #o0030 ans 1)
+    (qfasl-next-nibble)
     (return (m-enter-fasl-table ans))))
 
 
@@ -901,7 +904,7 @@
 ;		sym:dtp-null)
 ;       (vstore-contents (+ (qintern function) 2) (vcontents (+ (qintern defsym) 2))))
      )
-    ((and (eq (car form) sym:forward-value-cell) ;(sym:quote ,alias-sym) (sym:quote ,defsym))
+    ((and (eq (car form) 'sym:forward-value-cell) ;(sym:quote ,alias-sym) (sym:quote ,defsym))
      (symbolp (cadr (cadr form))) (symbolp (cadr (caddr form))))
      (push form evals-to-be-sent-over)
      (vstore-contents (+ (qintern (cadr (cadr form))) 1)

Modified: trunk/tools/cold/coldut.lisp
==============================================================================
--- trunk/tools/cold/coldut.lisp	Sun Jun 12 18:12:41 2016	(r453)
+++ trunk/tools/cold/coldut.lisp	Sun Jun 12 18:47:19 2016	(r454)
@@ -753,11 +753,14 @@
 (defun store-flonum (area number)
   (and (memq area sym:list-structured-areas)
        (error "extended-number in list-structured area ~S" area))
-  (format t "store-flonum: ~S ~S~%" (type-of number) number)
+  (format t "store-flonum: ~S ~F~%" (type-of number) number)
   (let* ((size 2) ; XXX (%structure-total-size number)
 	 (adr (allocate-block area size)))
-    (loop for i from 0 below size
-	  do (vwrite (+ adr i) number))
+    (vwrite-cdr adr sym:cdr-nil
+		(lispm-dpb sym:dtp-header sym:%%q-all-but-pointer
+			   (lispm-dpb sym:%header-type-flonum
+				      sym:%%header-type-field (1- size))))
+    ;(vwrite (+ adr 1) (ldb (byte 31 0) number))
     (vmake-pointer sym:dtp-extended-number adr)))
 
 ;;; New version of qintern.  Machine builds obarray when it first comes up (easy enough).