From rswindells at common-lisp.net Sun Jun 12 18:10:13 2016 From: rswindells at common-lisp.net (rswindells at common-lisp.net) Date: Sun, 12 Jun 2016 18:10:13 +0000 Subject: r452 - trunk/tools/cold Message-ID: Author: rswindells Date: Sun Jun 12 18:10:13 2016 New Revision: 452 Log: Fix forward-value-cell case in q-fasl-op-eval1. Helps loading QIO.QFASL from system 99. Modified: trunk/tools/cold/coldld.lisp Modified: trunk/tools/cold/coldld.lisp ============================================================================== --- trunk/tools/cold/coldld.lisp Thu May 26 14:29:10 2016 (r451) +++ trunk/tools/cold/coldld.lisp Sun Jun 12 18:10:13 2016 (r452) @@ -902,13 +902,14 @@ ; 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) (lispm-dpb sym:dtp-one-q-forward sym:%%q-data-type - (+ (qintern (cadr (caddr form))) 1)))) + (+ (qintern (cadr (caddr form))) 1))) + (m-q-enter-fasl-table nil qnil)) (t ;; If this is a defvar or defconst, store the value now ;; in addition to causing it to be evaluated later. From rswindells at common-lisp.net Sun Jun 12 18:12:41 2016 From: rswindells at common-lisp.net (rswindells at common-lisp.net) Date: Sun, 12 Jun 2016 18:12:41 +0000 Subject: r453 - trunk/tools/cold Message-ID: Author: rswindells Date: Sun Jun 12 18:12:41 2016 New Revision: 453 Log: Add fasl op for characters. Modified: trunk/tools/cold/coldld.lisp Modified: trunk/tools/cold/coldld.lisp ============================================================================== --- trunk/tools/cold/coldld.lisp Sun Jun 12 18:10:13 2016 (r452) +++ trunk/tools/cold/coldld.lisp Sun Jun 12 18:12:41 2016 (r453) @@ -304,18 +304,17 @@ (m-enter-fasl-table ans)) (setq ans (lispm-dpb (qfasl-next-nibble) (+ (ash pos 6) #o20) ans)))) -;Generate a FIXNUM (or BIGNUM) value. +;Generate a CHARACTER value. (defun m-fasl-op-character () - (error "m-fasl-op-character")) - -; (do ((pos (* (1- fasl-group-length) #o20) (- pos #o20)) -; (c fasl-group-length (1- c)) -; (ans 0)) -; ((zerop c) -; (cond (fasl-group-flag (setq ans (- 0 ans)))) -; (setq ans (%make-pointer sym:dtp-character ans)) -; (m-enter-fasl-table ans)) -; (setq ans (lispm-dpb (qfasl-next-nibble) (+ (ash pos 6) #o20) ans)))) + (do ((pos (* (1- fasl-group-length) #o20) (- pos #o20)) + (c fasl-group-length (1- c)) + (ans 0)) + ((zerop c) + (cond (fasl-group-flag (setq ans (- 0 ans)))) + ;; comment out next line if building earlier than system 99 + (setq ans (%make-pointer sym:dtp-character ans)) + (m-enter-fasl-table ans)) + (setq ans (lispm-dpb (qfasl-next-nibble) (+ (ash pos 6) #o20) ans)))) ;;; NEW FLOAT OP!! not yet written. See sys; qfasl From rswindells at common-lisp.net Sun Jun 12 18:47:19 2016 From: rswindells at common-lisp.net (rswindells at common-lisp.net) Date: Sun, 12 Jun 2016 18:47:19 +0000 Subject: r454 - trunk/tools/cold Message-ID: 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). From rswindells at common-lisp.net Sun Jun 12 19:04:30 2016 From: rswindells at common-lisp.net (rswindells at common-lisp.net) Date: Sun, 12 Jun 2016 19:04:30 +0000 Subject: r455 - trunk/tools/cold Message-ID: Author: rswindells Date: Sun Jun 12 19:04:30 2016 New Revision: 455 Log: Output characters if found in input. Modified: trunk/tools/cold/coldut.lisp Modified: trunk/tools/cold/coldut.lisp ============================================================================== --- trunk/tools/cold/coldut.lisp Sun Jun 12 18:47:19 2016 (r454) +++ trunk/tools/cold/coldut.lisp Sun Jun 12 19:04:30 2016 (r455) @@ -640,8 +640,8 @@ ((floatp s-exp) (store-flonum 'sym:working-storage-area s-exp)) ((and (<= s-exp big-fixnum) (>= s-exp little-fixnum)) (vfix s-exp)) (t (store-bignum 'sym:working-storage-area s-exp)))) -; ((characterp s-exp) -; (vmake-pointer sym:dtp-character (char-int s-exp))) + ((characterp s-exp) + (vmake-pointer sym:dtp-character (char-int s-exp))) ((symbolp s-exp) (qintern s-exp)) ((stringp s-exp) (store-string 'sym:p-n-string s-exp)) ((atom s-exp) (error "~S unknown type" s-exp)) From rswindells at common-lisp.net Sun Jun 12 19:06:08 2016 From: rswindells at common-lisp.net (rswindells at common-lisp.net) Date: Sun, 12 Jun 2016 19:06:08 +0000 Subject: r456 - trunk/tools/cold Message-ID: Author: rswindells Date: Sun Jun 12 19:06:08 2016 New Revision: 456 Log: Take out test for array-index-order. Trying to load old QFASL files into a new cold load won't work but we have a new version of RDTBL.QFASL. Modified: trunk/tools/cold/coldld.lisp Modified: trunk/tools/cold/coldld.lisp ============================================================================== --- trunk/tools/cold/coldld.lisp Sun Jun 12 19:04:30 2016 (r455) +++ trunk/tools/cold/coldld.lisp Sun Jun 12 19:06:08 2016 (r456) @@ -515,12 +515,10 @@ (unless (<= 1 (length last-array-dims) 2) (error "Only 1 and 2-dimensional arrays can be loaded.")) (setq ptr (+ ptr (if long-flag 1 0) ndims)) ;To data - (if (eq array-index-order sym:new-array-index-order) - ;; Order of data matches order in world being created, so it's easy. - (dotimes (n num) ;Initialize specified num of vals - (vwrite ptr (q-fasl-next-value)) - (setq ptr (1+ ptr))) - (error "Need to swap array dimensions.")) + ;; Order of data matches order in world being created, so it's easy. + (dotimes (n num) ;Initialize specified num of vals + (vwrite ptr (q-fasl-next-value)) + (setq ptr (1+ ptr))) ;; XXX ; (let ((temp1 (make-array last-array-dims :initial-element qnil)) temp2) ; ;; Read in the values, then transpose them, @@ -554,16 +552,13 @@ (eq last-array-type 'sym:art-16b))) (error "Only 1-dimensional, or 2-dimensional art-16b, numeric arrays can be loaded.")) - (if (or (= (length last-array-dims) 1) - (eq array-index-order sym:new-array-index-order)) - ;; Order of data matches order in world being created, so it's easy. - (progn - (dotimes (n (/ num 2)) ;Initialize specified num of vals - (vwrite ptr (+ (qfasl-nibble) (ash (qfasl-nibble) 16.))) - (setq ptr (1+ ptr))) - (cond ((oddp num) ;odd, catch last nibble - (vwrite ptr (qfasl-nibble))))) - (error "Need to swap array dimensions.")) + ;; Order of data matches order in world being created, so it's easy. + (progn + (dotimes (n (/ num 2)) ;Initialize specified num of vals + (vwrite ptr (+ (qfasl-nibble) (ash (qfasl-nibble) 16.))) + (setq ptr (1+ ptr))) + (cond ((oddp num) ;odd, catch last nibble + (vwrite ptr (qfasl-nibble))))) ;; XXX ; (let ((temp1 (make-array last-array-dims ':type art-16b)) temp2) ;; Read in the values, then transpose them,