X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fearly-extensions.lisp;h=65f98d72c0e19892034ee2dd8d12cc13d95fc2af;hb=e87722978bc9993cc5a862964366ee7cd0b7fb4c;hp=2c6263a90fc7f15c1f962c0e5cee4f928f903232;hpb=51e63f301624e39febdd85b5feba19b7c980f307;p=sbcl.git diff --git a/src/code/early-extensions.lisp b/src/code/early-extensions.lisp index 2c6263a..65f98d7 100644 --- a/src/code/early-extensions.lisp +++ b/src/code/early-extensions.lisp @@ -30,6 +30,10 @@ ;;; bound because ANSI specifies it as an exclusive bound.) (def!type index () `(integer 0 (,sb!xc:array-dimension-limit))) +;;; like INDEX, but only up to half the maximum. Used by hash-table +;;; code that does plenty to (aref v (* 2 i)) and (aref v (1+ (* 2 i))). +(def!type index/2 () `(integer 0 (,(floor sb!xc:array-dimension-limit 2)))) + ;;; like INDEX, but augmented with -1 (useful when using the index ;;; to count downwards to 0, e.g. LOOP FOR I FROM N DOWNTO 0, with ;;; an implementation which terminates the loop by testing for the @@ -65,7 +69,7 @@ (* max-offset sb!vm:n-word-bytes)) scale))) -#!+x86 +#!+(or x86 x86-64) (defun displacement-bounds (lowtag element-size data-offset) (let* ((adjustment (- (* data-offset sb!vm:n-word-bytes) lowtag)) (bytes-per-element (ceiling element-size sb!vm:n-byte-bits)) @@ -75,7 +79,7 @@ bytes-per-element))) (values min max))) -#!+x86 +#!+(or x86 x86-64) (def!type constant-displacement (lowtag element-size data-offset) (flet ((integerify (x) (etypecase x @@ -920,71 +924,19 @@ ;;; handle arbitrary combinations of atoms using NOT, AND, OR. (defun featurep (x) (if (consp x) - (case (car x) - ((:not not) - (if (cddr x) - (error "too many subexpressions in feature expression: ~S" x) - (not (featurep (cadr x))))) - ((:and and) (every #'featurep (cdr x))) - ((:or or) (some #'featurep (cdr x))) - (t - (error "unknown operator in feature expression: ~S." x))) - (not (null (memq x *features*))))) - -;;; Given a list of keyword substitutions `(,OLD ,NEW), and a -;;; &KEY-argument-list-style list of alternating keywords and -;;; arbitrary values, return a new &KEY-argument-list-style list with -;;; all substitutions applied to it. -;;; -;;; Note: If efficiency mattered, we could do less consing. (But if -;;; efficiency mattered, why would we be using &KEY arguments at -;;; all, much less renaming &KEY arguments?) -;;; -;;; KLUDGE: It would probably be good to get rid of this. -- WHN 19991201 -(defun rename-key-args (rename-list key-args) - (declare (type list rename-list key-args)) - ;; Walk through RENAME-LIST modifying RESULT as per each element in - ;; RENAME-LIST. - (do ((result (copy-list key-args))) ; may be modified below - ((null rename-list) result) - (destructuring-bind (old new) (pop rename-list) - ;; ANSI says &KEY arg names aren't necessarily KEYWORDs. - (declare (type symbol old new)) - ;; Walk through RESULT renaming any OLD key argument to NEW. - (do ((in-result result (cddr in-result))) - ((null in-result)) - (declare (type list in-result)) - (when (eq (car in-result) old) - (setf (car in-result) new)))))) - -;;; ANSI Common Lisp's READ-SEQUENCE function, unlike most of the -;;; other ANSI input functions, is defined to communicate end of file -;;; status with its return value, not by signalling. That is not the -;;; behavior that we usually want. This function is a wrapper which -;;; restores the behavior that we usually want, causing READ-SEQUENCE -;;; to communicate end-of-file status by signalling. -(defun read-sequence-or-die (sequence stream &key start end) - ;; implementation using READ-SEQUENCE - #-no-ansi-read-sequence - (let ((read-end (read-sequence sequence - stream - :start start - :end end))) - (unless (= read-end end) - (error 'end-of-file :stream stream)) - (values)) - ;; workaround for broken READ-SEQUENCE - #+no-ansi-read-sequence - (progn - (aver (<= start end)) - (let ((etype (stream-element-type stream))) - (cond ((equal etype '(unsigned-byte 8)) - (do ((i start (1+ i))) - ((>= i end) - (values)) - (setf (aref sequence i) - (read-byte stream)))) - (t (error "unsupported element type ~S" etype)))))) + (case (car x) + ((:not not) + (cond + ((cddr x) + (error "too many subexpressions in feature expression: ~S" x)) + ((null (cdr x)) + (error "too few subexpressions in feature expression: ~S" x)) + (t (not (featurep (cadr x)))))) + ((:and and) (every #'featurep (cdr x))) + ((:or or) (some #'featurep (cdr x))) + (t + (error "unknown operator in feature expression: ~S." x))) + (not (null (memq x *features*))))) ;;;; utilities for two-VALUES predicates @@ -1253,3 +1205,53 @@ an implementation of EVAL that calls the compiler will be used. If set to :INTERPRET, an interpreter will be used.") +;;; Helper for making the DX closure allocation in macros expanding +;;; to CALL-WITH-FOO less ugly. +;;; +;;; This expands to something like +;;; +;;; (flet ((foo (...) )) +;;; (declare (optimize stack-allocate-dynamic-extent)) +;;; (flet ((foo (...) +;;; (foo ...)) +;;; (declare (dynamic-extent #'foo)) +;;; ))) +;;; +;;; The outer FLETs are inlined into the inner ones, and the inner ones +;;; are DX-allocated. The double-fletting is done to keep the bodies of +;;; the functions in an environment with correct policy: we don't want +;;; to force DX allocation in their bodies, which would be bad eg. +;;; in safe code. +(defmacro dx-flet (functions &body forms) + (let ((names (mapcar #'car functions))) + `(flet ,functions + #-sb-xc-host + (declare (optimize sb!c::stack-allocate-dynamic-extent)) + (flet ,(mapcar + (lambda (f) + (let ((args (cadr f)) + (name (car f))) + (when (intersection args lambda-list-keywords) + ;; No fundamental reason not to support them, but we + ;; don't currently need them here. + (error "Non-required arguments not implemented for DX-FLET.")) + `(,name ,args + (,name ,@args)))) + functions) + (declare (dynamic-extent ,@(mapcar (lambda (x) `(function ,x)) names))) + ,@forms)))) + +;;; Another similar one -- but actually touches the policy of the body, +;;; so take care with this one... +(defmacro dx-let (bindings &body forms) + `(locally + #-sb-xc-host + (declare (optimize sb!c::stack-allocate-dynamic-extent)) + (let ,bindings + (declare (dynamic-extent ,@(mapcar (lambda (bind) + (if (consp bind) + (car bind) + bind)) + bindings))) + ,@forms))) +