X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ffop.lisp;h=6a6b94919bae6a71992c057c575a0ea0f070cf66;hb=a22dd643fb599880f4c0856e1a85bffe4358aea8;hp=f2ec21c55bb3e6f92e31e5618a7b930bc6834430;hpb=f6a2be77637d025bfded9430f02863c28f74f77a;p=sbcl.git diff --git a/src/code/fop.lisp b/src/code/fop.lisp index f2ec21c..6a6b949 100644 --- a/src/code/fop.lisp +++ b/src/code/fop.lisp @@ -37,7 +37,7 @@ ;;; Define a pair of fops which are identical except that one reads ;;; a four-byte argument while the other reads a one-byte argument. The -;;; argument can be accessed by using the Clone-Arg macro. +;;; argument can be accessed by using the CLONE-ARG macro. ;;; ;;; KLUDGE: It would be nice if the definition here encapsulated which ;;; value ranges went with which fop variant, and chose the correct @@ -123,8 +123,6 @@ #-sb-xc-host (%primitive sb!c:make-other-immediate-type 0 sb!vm:unbound-marker-widetag)) -(define-fop (fop-character 68) - (code-char (read-arg 3))) ;;; CMU CL had FOP-CHARACTER as fop 68, but it's not needed in current ;;; SBCL as we have no extended characters, only 1-byte characters. ;;; (Ditto for CMU CL, actually: FOP-CHARACTER was speculative generality.) @@ -137,7 +135,7 @@ (declare (type index size)) (do ((n (1- size) (1- n))) ((minusp n)) - (declare (type (integer -1 #.most-positive-fixnum) n)) + (declare (type index-or-minus-1 n)) (setf (%instance-ref res n) (pop-stack))) res)) @@ -161,10 +159,10 @@ (define-fop (fop-verify-table-size 62 :stackp nil) (let ((expected-index (read-arg 4))) (unless (= *current-fop-table-index* expected-index) - (error "internal error: fasl table of improper size")))) + (bug "fasl table of improper size")))) (define-fop (fop-verify-empty-stack 63 :stackp nil) - (unless (= *fop-stack-pointer* *fop-stack-pointer-on-entry*) - (error "internal error: fasl stack not empty when it should be"))) + (unless (zerop (length *fop-stack*)) + (bug "fasl stack not empty when it should be"))) ;;;; fops for loading symbols @@ -290,64 +288,41 @@ (let ((im (pop-stack))) (%make-complex (pop-stack) im))) -(define-fop (fop-complex-single-float 72) - (prepare-for-fast-read-byte *fasl-input-stream* - (prog1 - (complex (make-single-float (fast-read-s-integer 4)) - (make-single-float (fast-read-s-integer 4))) - (done-with-fast-read-byte)))) - -(define-fop (fop-complex-double-float 73) - (prepare-for-fast-read-byte *fasl-input-stream* - (prog1 - (let* ((re-lo (fast-read-u-integer 4)) - (re-hi (fast-read-u-integer 4)) - (re (make-double-float re-hi re-lo)) - (im-lo (fast-read-u-integer 4)) - (im-hi (fast-read-u-integer 4)) - (im (make-double-float im-hi im-lo))) - (complex re im)) - (done-with-fast-read-byte)))) - -#!+long-float -(define-fop (fop-complex-long-float 67) - (prepare-for-fast-read-byte *fasl-input-stream* - (prog1 - (let* ((re-lo (fast-read-u-integer 4)) - #!+sparc (re-mid (fast-read-u-integer 4)) - (re-hi (fast-read-u-integer 4)) - (re-exp (fast-read-s-integer #!+x86 2 #!+sparc 4)) - (re (make-long-float re-exp re-hi #!+sparc re-mid re-lo)) - (im-lo (fast-read-u-integer 4)) - #!+sparc (im-mid (fast-read-u-integer 4)) - (im-hi (fast-read-u-integer 4)) - (im-exp (fast-read-s-integer #!+x86 2 #!+sparc 4)) - (im (make-long-float im-exp im-hi #!+sparc im-mid im-lo))) - (complex re im)) - (done-with-fast-read-byte)))) - -(define-fop (fop-single-float 46) - (prepare-for-fast-read-byte *fasl-input-stream* - (prog1 (make-single-float (fast-read-s-integer 4)) - (done-with-fast-read-byte)))) - -(define-fop (fop-double-float 47) - (prepare-for-fast-read-byte *fasl-input-stream* - (prog1 - (let ((lo (fast-read-u-integer 4))) - (make-double-float (fast-read-s-integer 4) lo)) - (done-with-fast-read-byte)))) +(macrolet ((fast-read-single-float () + '(make-single-float (fast-read-s-integer 4))) + (fast-read-double-float () + '(let ((lo (fast-read-u-integer 4))) + (make-double-float (fast-read-s-integer 4) lo))) + #!+long-float + (fast-read-long-float () + '(let ((lo (fast-read-u-integer 4)) + #!+sparc (mid (fast-read-u-integer 4)) + (hi (fast-read-u-integer 4)) ; XXX + (exp (fast-read-s-integer #!+x86 2 #!+sparc 4))) + (make-long-float exp hi #!+sparc mid lo)))) + (macrolet ((define-complex-fop (name fop-code type) + (let ((reader (symbolicate "FAST-READ-" type))) + `(define-fop (,name ,fop-code) + (prepare-for-fast-read-byte *fasl-input-stream* + (prog1 + (complex (,reader) (,reader)) + (done-with-fast-read-byte)))))) + (define-float-fop (name fop-code type) + (let ((reader (symbolicate "FAST-READ-" type))) + `(define-fop (,name ,fop-code) + (prepare-for-fast-read-byte *fasl-input-stream* + (prog1 + (,reader) + (done-with-fast-read-byte))))))) + (define-complex-fop fop-complex-single-float 72 single-float) + (define-complex-fop fop-complex-double-float 73 double-float) + #!+long-float + (define-complex-fop fop-complex-long-float 67 long-float) + (define-float-fop fop-single-float 46 single-float) + (define-float-fop fop-double-float 47 double-float) + #!+long-float + (define-float-fop fop-long-float 52 long-float))) -#!+long-float -(define-fop (fop-long-float 52) - (prepare-for-fast-read-byte *fasl-input-stream* - (prog1 - (let ((lo (fast-read-u-integer 4)) - #!+sparc (mid (fast-read-u-integer 4)) - (hi (fast-read-u-integer 4)) - (exp (fast-read-s-integer #!+x86 2 #!+sparc 4))) - (make-long-float exp hi #!+sparc mid lo)) - (done-with-fast-read-byte)))) ;;;; loading lists @@ -365,7 +340,7 @@ (macrolet ((frob (name op fun n) `(define-fop (,name ,op) - (call-with-popped-things ,fun ,n)))) + (call-with-popped-args ,fun ,n)))) (frob fop-list-1 17 list 1) (frob fop-list-2 18 list 2) @@ -472,14 +447,20 @@ (let* ((len (fast-read-u-integer 4)) (size (fast-read-byte)) (res (case size + (0 (make-array len :element-type 'nil)) (1 (make-array len :element-type 'bit)) (2 (make-array len :element-type '(unsigned-byte 2))) (4 (make-array len :element-type '(unsigned-byte 4))) + (7 (prog1 (make-array len :element-type '(unsigned-byte 7)) + (setf size 8))) (8 (make-array len :element-type '(unsigned-byte 8))) + (15 (prog1 (make-array len :element-type '(unsigned-byte 15)) + (setf size 16))) (16 (make-array len :element-type '(unsigned-byte 16))) + (31 (prog1 (make-array len :element-type '(unsigned-byte 31)) + (setf size 32))) (32 (make-array len :element-type '(unsigned-byte 32))) - (t (error "internal error: losing i-vector element size: ~S" - size))))) + (t (bug "losing i-vector element size: ~S" size))))) (declare (type index len)) (done-with-fast-read-byte) (read-n-bytes *fasl-input-stream* @@ -498,16 +479,16 @@ (res (case size (8 (make-array len :element-type '(signed-byte 8))) (16 (make-array len :element-type '(signed-byte 16))) + (29 (make-array len :element-type '(unsigned-byte 29))) (30 (make-array len :element-type '(signed-byte 30))) (32 (make-array len :element-type '(signed-byte 32))) - (t (error "internal error: losing si-vector element size: ~S" - size))))) + (t (bug "losing si-vector element size: ~S" size))))) (declare (type index len)) (done-with-fast-read-byte) (read-n-bytes *fasl-input-stream* res 0 - (ceiling (the index (* (if (= size 30) + (ceiling (the index (* (if (or (= size 30) (= size 29)) 32 ; Adjust for (signed-byte 30) size) len)) sb!vm:n-byte-bits)) res))) @@ -646,8 +627,7 @@ bug.~:@>") (offset (read-arg 4))) (declare (type index offset)) (unless (zerop (logand offset sb!vm:lowtag-mask)) - (error "internal error: unaligned function object, offset = #X~X" - offset)) + (bug "unaligned function object, offset = #X~X" offset)) (let ((fun (%primitive sb!c:compute-fun code-object offset))) (setf (%simple-fun-self fun) fun) (setf (%simple-fun-next fun) (%code-entry-points code-object))