From 5e3fb5149366dd84a5cb76bf1cf5f2324c24ca57 Mon Sep 17 00:00:00 2001 From: William Harold Newman Date: Mon, 20 Aug 2001 23:05:35 +0000 Subject: [PATCH] 0.pre7.14.flaky4.4: (This version still can't build itself, dying in cross-compilation of debug-int.lisp.) revised FUNCALL-IN-MACROLET-LEXENV to look more like FUNCALL-IN-SYMBOL-MACROLET-LEXENV reimplemented ONCE-ONLY so it expands into a single LET, so that DECLAREs inside work as they should commented out bogus macroexpansion-time DECLAREs in UNIX-FAST-SELECT --- src/code/byte-interp.lisp | 4 +- src/code/debug-int.lisp | 101 +++++++++++++++++++++------------------------ src/code/serve-event.lisp | 9 ++-- src/code/toplevel.lisp | 18 ++++---- src/code/unix.lisp | 10 ++++- src/compiler/ir1tran.lisp | 59 ++++++++++++++------------ 6 files changed, 105 insertions(+), 96 deletions(-) diff --git a/src/code/byte-interp.lisp b/src/code/byte-interp.lisp index 738f901..a309344 100644 --- a/src/code/byte-interp.lisp +++ b/src/code/byte-interp.lisp @@ -92,9 +92,9 @@ (setf sb!eval::*eval-stack* new-stack))) (setf *eval-stack-top* new-sp) (let ((stack sb!eval::*eval-stack*)) - (do ((i sp (1+ i))) ; FIXME: DOTIMES? or just :INITIAL-ELEMENT in MAKE-ARRAY? + (do ((i sp (1+ i))) ; FIXME: Use CL:FILL. ((= i new-sp)) - (setf (svref stack i) '#:uninitialized)))) + (setf (svref stack i) '#:uninitialized-eval-stack-element)))) (values)) (defun pop-eval-stack () diff --git a/src/code/debug-int.lisp b/src/code/debug-int.lisp index a63c1ba..f477b91 100644 --- a/src/code/debug-int.lisp +++ b/src/code/debug-int.lisp @@ -1365,14 +1365,14 @@ ;;;; operations on DEBUG-FUNCTIONs +;;; Execute the forms in a context with block-var bound to each +;;; debug-block in debug-function successively. Result is an optional +;;; form to execute for return values, and DO-DEBUG-FUNCTION-BLOCKS +;;; returns nil if there is no result form. This signals a +;;; no-debug-blocks condition when the debug-function lacks +;;; debug-block information. (defmacro do-debug-function-blocks ((block-var debug-function &optional result) &body body) - #!+sb-doc - "Executes the forms in a context with block-var bound to each debug-block in - debug-function successively. Result is an optional form to execute for - return values, and DO-DEBUG-FUNCTION-BLOCKS returns nil if there is no - result form. This signals a no-debug-blocks condition when the - debug-function lacks debug-block information." (let ((blocks (gensym)) (i (gensym))) `(let ((,blocks (debug-function-debug-blocks ,debug-function))) @@ -1381,14 +1381,13 @@ (let ((,block-var (svref ,blocks ,i))) ,@body))))) +;;; Execute body in a context with var bound to each debug-var in +;;; debug-function. This returns the value of executing result (defaults to +;;; nil). This may iterate over only some of debug-function's variables or none +;;; depending on debug policy; for example, possibly the compilation only +;;; preserved argument information. (defmacro do-debug-function-variables ((var debug-function &optional result) &body body) - #!+sb-doc - "Executes body in a context with var bound to each debug-var in - debug-function. This returns the value of executing result (defaults to - nil). This may iterate over only some of debug-function's variables or none - depending on debug policy; for example, possibly the compilation only - preserved argument information." (let ((vars (gensym)) (i (gensym))) `(let ((,vars (debug-function-debug-vars ,debug-function))) @@ -1399,11 +1398,10 @@ ,@body)) ,result)))) +;;; Return the Common Lisp function associated with the debug-function. This +;;; returns nil if the function is unavailable or is non-existent as a user +;;; callable function object. (defun debug-function-function (debug-function) - #!+sb-doc - "Returns the Common Lisp function associated with the debug-function. This - returns nil if the function is unavailable or is non-existent as a user - callable function object." (let ((cached-value (debug-function-%function debug-function))) (if (eq cached-value :unparsed) (setf (debug-function-%function debug-function) @@ -1430,10 +1428,9 @@ (bogus-debug-function nil))) cached-value))) +;;; Return the name of the function represented by debug-function. This may +;;; be a string or a cons; do not assume it is a symbol. (defun debug-function-name (debug-function) - #!+sb-doc - "Returns the name of the function represented by debug-function. This may - be a string or a cons; do not assume it is a symbol." (etypecase debug-function (compiled-debug-function (sb!c::compiled-debug-function-name @@ -1444,9 +1441,8 @@ (bogus-debug-function (bogus-debug-function-%name debug-function)))) +;;; Return a debug-function that represents debug information for function. (defun function-debug-function (fun) - #!+sb-doc - "Returns a debug-function that represents debug information for function." (case (get-type fun) (#.sb!vm:closure-header-type (function-debug-function (%closure-function fun))) @@ -1483,10 +1479,9 @@ (get-header-data component)) sb!vm:word-bytes))))))) +;;; Return the kind of the function, which is one of :OPTIONAL, +;;; :EXTERNAL, TOP-level, :CLEANUP, or NIL. (defun debug-function-kind (debug-function) - #!+sb-doc - "Returns the kind of the function which is one of :OPTIONAL, :EXTERNAL, - :TOP-level, :CLEANUP, or NIL." ;; FIXME: This "is one of" information should become part of the function ;; declamation, not just a doc string (etypecase debug-function @@ -1499,19 +1494,17 @@ (bogus-debug-function nil))) +;;; Is there any variable information for DEBUG-FUNCTION? (defun debug-var-info-available (debug-function) - #!+sb-doc - "Is there any variable information for DEBUG-FUNCTION?" (not (not (debug-function-debug-vars debug-function)))) +;;; Return a list of debug-vars in debug-function having the same name +;;; and package as symbol. If symbol is uninterned, then this returns +;;; a list of debug-vars without package names and with the same name +;;; as symbol. The result of this function is limited to the +;;; availability of variable information in debug-function; for +;;; example, possibly DEBUG-FUNCTION only knows about its arguments. (defun debug-function-symbol-variables (debug-function symbol) - #!+sb-doc - "Returns a list of debug-vars in debug-function having the same name - and package as symbol. If symbol is uninterned, then this returns a list of - debug-vars without package names and with the same name as symbol. The - result of this function is limited to the availability of variable - information in debug-function; for example, possibly debug-function only - knows about its arguments." (let ((vars (ambiguous-debug-vars debug-function (symbol-name symbol))) (package (and (symbol-package symbol) (package-name (symbol-package symbol))))) @@ -1524,11 +1517,12 @@ (stringp (debug-var-package-name var)))) vars))) +;;; Return a list of debug-vars in debug-function whose names contain +;;; name-prefix-string as an intial substring. The result of this +;;; function is limited to the availability of variable information in +;;; debug-function; for example, possibly debug-function only knows +;;; about its arguments. (defun ambiguous-debug-vars (debug-function name-prefix-string) - "Returns a list of debug-vars in debug-function whose names contain - name-prefix-string as an intial substring. The result of this function is - limited to the availability of variable information in debug-function; for - example, possibly debug-function only knows about its arguments." (declare (simple-string name-prefix-string)) (let ((variables (debug-function-debug-vars debug-function))) (declare (type (or null simple-vector) variables)) @@ -1569,24 +1563,25 @@ (string= x y :end1 name-len :end2 name-len)))) :end (or end (length variables))))) +;;; Return a list representing the lambda-list for DEBUG-FUNCTION. The +;;; list has the following structure: +;;; (required-var1 required-var2 +;;; ... +;;; (:optional var3 suppliedp-var4) +;;; (:optional var5) +;;; ... +;;; (:rest var6) (:rest var7) +;;; ... +;;; (:keyword keyword-symbol var8 suppliedp-var9) +;;; (:keyword keyword-symbol var10) +;;; ... +;;; ) +;;; Each VARi is a DEBUG-VAR; however it may be the symbol :DELETED if +;;; it is unreferenced in DEBUG-FUNCTION. This signals a +;;; LAMBDA-LIST-UNAVAILABLE condition when there is no argument list +;;; information. (defun debug-function-lambda-list (debug-function) #!+sb-doc - "Returns a list representing the lambda-list for debug-function. The list - has the following structure: - (required-var1 required-var2 - ... - (:optional var3 suppliedp-var4) - (:optional var5) - ... - (:rest var6) (:rest var7) - ... - (:keyword keyword-symbol var8 suppliedp-var9) - (:keyword keyword-symbol var10) - ... - ) - Each VARi is a DEBUG-VAR; however it may be the symbol :deleted it - is unreferenced in debug-function. This signals a lambda-list-unavailable - condition when there is no argument list information." (etypecase debug-function (compiled-debug-function (compiled-debug-function-lambda-list debug-function)) diff --git a/src/code/serve-event.lisp b/src/code/serve-event.lisp index 55482c4..f0c6961 100644 --- a/src/code/serve-event.lisp +++ b/src/code/serve-event.lisp @@ -307,10 +307,11 @@ (sb!alien:with-alien ((read-fds (sb!alien:struct sb!unix:fd-set)) (write-fds (sb!alien:struct sb!unix:fd-set))) (let ((count (calc-masks))) - (multiple-value-bind (value err) (sb!unix:unix-fast-select - count - (sb!alien:addr read-fds) (sb!alien:addr write-fds) - nil to-sec to-usec) + (multiple-value-bind (value err) + (sb!unix:unix-fast-select count + (sb!alien:addr read-fds) + (sb!alien:addr write-fds) + nil to-sec to-usec) ;; Now see what it was (if anything) (cond (value diff --git a/src/code/toplevel.lisp b/src/code/toplevel.lisp index 410f1a6..2112163 100644 --- a/src/code/toplevel.lisp +++ b/src/code/toplevel.lisp @@ -157,16 +157,16 @@ (defconstant bytes-per-scrub-unit 2048) +;;; Zero the unused portion of the control stack so that old objects are not +;;; kept alive because of uninitialized stack variables. +;;; +;;; FIXME: Why do we need to do this instead of just letting GC read +;;; the stack pointer and avoid messing with the unused portion of +;;; the control stack? (Is this a multithreading thing where there's +;;; one control stack and stack pointer per thread, and it might not +;;; be easy to tell what a thread's stack pointer value is when +;;; looking in from another thread?) (defun scrub-control-stack () - #!+sb-doc - "Zero the unused portion of the control stack so that old objects are not - kept alive because of uninitialized stack variables." - ;; FIXME: Why do we need to do this instead of just letting GC read - ;; the stack pointer and avoid messing with the unused portion of - ;; the control stack? (Is this a multithreading thing where there's - ;; one control stack and stack pointer per thread, and it might not - ;; be easy to tell what a thread's stack pointer value is when - ;; looking in from another thread?) (declare (optimize (speed 3) (safety 0)) (values (unsigned-byte 20))) ; FIXME: DECLARE VALUES? diff --git a/src/code/unix.lisp b/src/code/unix.lisp index 0a405ca..0c03f2b 100644 --- a/src/code/unix.lisp +++ b/src/code/unix.lisp @@ -444,11 +444,17 @@ timeout-secs &optional (timeout-usecs 0)) #!+sb-doc "Perform the UNIX select(2) system call." - (declare (type (integer 0 #.FD-SETSIZE) num-descriptors) + ;; FIXME: These DECLAREs don't belong at macroexpansion time. They + ;; should be done at runtime instead. Perhaps we could just redo + ;; UNIX-FAST-SELECT as an inline function, and then all the + ;; declarations would work nicely. + #| + (declare (type (integer 0 #.fd-setsize) num-descriptors) (type (or (alien (* (struct fd-set))) null) read-fds write-fds exception-fds) (type (or null (unsigned-byte 31)) timeout-secs) - (type (unsigned-byte 31) timeout-usecs) ) + (type (unsigned-byte 31) timeout-usecs)) + |# ;; FIXME: CMU CL had ;; (optimize (speed 3) (safety 0) (inhibit-warnings 3)) ;; in the declarations above. If they're important, they should diff --git a/src/compiler/ir1tran.lisp b/src/compiler/ir1tran.lisp index ce4326b..271931d 100644 --- a/src/compiler/ir1tran.lisp +++ b/src/compiler/ir1tran.lisp @@ -2028,31 +2028,37 @@ ;;; call FUN (with no arguments). ;;; ;;; This is split off from the IR1 convert method so that it can be -;;; shared by the special-case top-level form processing code. +;;; shared by the special-case top-level MACROLET processing code. (defun funcall-in-macrolet-lexenv (definitions fun) (declare (type list definitions) (type function fun)) - (let ((whole (gensym "WHOLE")) - (environment (gensym "ENVIRONMENT"))) - (collect ((new-fenv)) - (dolist (def definitions) - (let ((name (first def)) - (arglist (second def)) - (body (cddr def))) - (unless (symbolp name) - (compiler-error "The local macro name ~S is not a symbol." name)) - (when (< (length def) 2) - (compiler-error - "The list ~S is too short to be a legal local macro definition." - name)) - (multiple-value-bind (body local-decs) - (parse-defmacro arglist whole body name 'macrolet - :environment environment) - (new-fenv `(,(first def) macro . - ,(coerce `(lambda (,whole ,environment) - ,@local-decs (block ,name ,body)) - 'function)))))) - (let ((*lexenv* (make-lexenv :functions (new-fenv)))) - (funcall fun)))) + (let* ((whole (gensym "WHOLE")) + (environment (gensym "ENVIRONMENT")) + (processed-definitions + (mapcar (lambda (definition) + (unless (list-of-length-at-least-p definition 2) + (compiler-error + "The list ~S is too short to be a legal ~ + local macro definition." + definition)) + (destructuring-bind (name arglist &body body) definition + (unless (symbolp name) + (compiler-error + "The local macro name ~S is not a symbol." name)) + (multiple-value-bind (body local-decls) + (parse-defmacro arglist whole body name 'macrolet + :environment environment) + `(,name macro . + ,(compile nil + `(lambda (,whole ,environment) + ,@local-decls + (block ,name ,body))))))) + definitions)) + (*lexenv* (make-lexenv :functions processed-definitions))) + (unless (= (length definitions) + (length (remove-duplicates definitions :key #'first))) + (compiler-style-warning + "duplicate macro names in MACROLET ~S" definitions)) + (funcall fun)) (values)) (def-ir1-translator macrolet ((definitions &rest body) start cont) @@ -2070,7 +2076,7 @@ ;;; then call FUN (with no arguments). ;;; ;;; This is split off from the IR1 convert method so that it can be -;;; shared by the special-case top-level form processing code. +;;; shared by the special-case top-level SYMBOL-MACROLET processing code. (defun funcall-in-symbol-macrolet-lexenv (macrobindings fun) (declare (type list macrobindings) (type function fun)) (let ((processed-macrobindings @@ -2081,13 +2087,14 @@ (destructuring-bind (name expansion) macrobinding (unless (symbolp name) (compiler-error - "The symbol macro name ~S is not a symbol." name)) + "The local symbol macro name ~S is not a symbol." + name)) `(,name . (MACRO . ,expansion)))) macrobindings))) (unless (= (length macrobindings) (length (remove-duplicates macrobindings :key #'first))) (compiler-style-warning - "duplicate names in SYMBOL-MACROLET ~S" macrobindings)) + "duplicate symbol macro names in SYMBOL-MACROLET ~S" macrobindings)) (let ((*lexenv* (make-lexenv :variables processed-macrobindings))) (funcall fun))) (values)) -- 1.7.10.4