X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fir1-translators.lisp;h=971550f40e457b2d28c0e40b45fbfdc47a5bf6f7;hb=b0b168c08b31a748150f404398af754f26fd4813;hp=021a7bf57b3d4eed851eb12b27d47322face78fd;hpb=e33fb894f991b2926d8f3bace9058e4c0b2c3a37;p=sbcl.git diff --git a/src/compiler/ir1-translators.lisp b/src/compiler/ir1-translators.lisp index 021a7bf..971550f 100644 --- a/src/compiler/ir1-translators.lisp +++ b/src/compiler/ir1-translators.lisp @@ -37,7 +37,7 @@ :alternative else-block))) (setf (continuation-dest pred) node) (ir1-convert start pred test) - (prev-link node pred) + (link-node-to-previous-continuation node pred) (use-continuation node dummy-cont) (let ((start-block (continuation-block pred))) @@ -75,7 +75,7 @@ :mess-up entry))) (push entry (lambda-entries (lexenv-lambda *lexenv*))) (setf (entry-cleanup entry) cleanup) - (prev-link entry start) + (link-node-to-previous-continuation entry start) (use-continuation entry dummy) (let* ((env-entry (list entry cont)) @@ -115,7 +115,7 @@ (push exit (entry-exits entry)) (setf (continuation-dest value-cont) exit) (ir1-convert start value-cont value) - (prev-link exit value-cont) + (link-node-to-previous-continuation exit value-cont) (let ((home-lambda (continuation-home-lambda-or-null start))) (when home-lambda (push entry (lambda-calls-or-closes home-lambda)))) @@ -169,7 +169,7 @@ :mess-up entry))) (push entry (lambda-entries (lexenv-lambda *lexenv*))) (setf (entry-cleanup entry) cleanup) - (prev-link entry start) + (link-node-to-previous-continuation entry start) (use-continuation entry dummy) (collect ((tags) @@ -204,7 +204,7 @@ (entry (first found)) (exit (make-exit :entry entry))) (push exit (entry-exits entry)) - (prev-link exit start) + (link-node-to-previous-continuation exit start) (let ((home-lambda (continuation-home-lambda-or-null start))) (when home-lambda (push entry (lambda-calls-or-closes home-lambda)))) @@ -244,11 +244,11 @@ definitions fun) (declare (type function definitionize-fun fun)) - (declare (type (member :variables :functions) definitionize-keyword)) + (declare (type (member :vars :funs) definitionize-keyword)) (declare (type list definitions)) (unless (= (length definitions) (length (remove-duplicates definitions :key #'first))) - (compiler-style-warning "duplicate definitions in ~S" definitions)) + (compiler-style-warn "duplicate definitions in ~S" definitions)) (let* ((processed-definitions (mapcar definitionize-fun definitions)) (*lexenv* (make-lexenv definitionize-keyword processed-definitions))) (funcall fun))) @@ -278,7 +278,7 @@ `(lambda (,whole ,environment) ,@local-decls (block ,name ,body)))))))) - :functions + :funs definitions fun)) @@ -304,7 +304,7 @@ "The local symbol macro name ~S is not a symbol." name)) `(,name . (MACRO . ,expansion)))) - :variables + :vars definitions fun)) @@ -398,19 +398,21 @@ ,@(subseq args 0 required) ,@(subseq args min))))) -;;;; QUOTE and FUNCTION +;;;; QUOTE (def-ir1-translator quote ((thing) start cont) #!+sb-doc "QUOTE Value Return Value without evaluating it." (reference-constant start cont thing)) + +;;;; FUNCTION and NAMED-LAMBDA (def-ir1-translator function ((thing) start cont) #!+sb-doc "FUNCTION Name Return the lexically apparent definition of the function Name. Name may also - be a lambda." + be a lambda expression." (if (consp thing) (case (car thing) ((lambda) @@ -420,7 +422,7 @@ :debug-name (debug-namify "#'~S" thing)))) ((setf) - (let ((var (find-lexically-apparent-function + (let ((var (find-lexically-apparent-fun thing "as the argument to FUNCTION"))) (reference-leaf start cont var))) ((instance-lambda) @@ -431,9 +433,37 @@ (reference-leaf start cont res))) (t (compiler-error "~S is not a legal function name." thing))) - (let ((var (find-lexically-apparent-function + (let ((var (find-lexically-apparent-fun thing "as the argument to FUNCTION"))) (reference-leaf start cont var)))) + +;;; `(NAMED-LAMBDA ,NAME ,@REST) is like `(FUNCTION (LAMBDA ,@REST)), +;;; except that the value of NAME is passed to the compiler for use in +;;; creation of debug information for the resulting function. +;;; +;;; Eventually we might use this for NAME values other than legal +;;; function names, e.g. +;;; NAME = (:FLET FOO BAR) +;;; for the FLET function in +;;; (DEFUN BAR (X) +;;; (FLET ((FOO (Y) (+ X Y))) +;;; FOO)) +;;; or +;;; NAME = (:METHOD PRINT-OBJECT (STARSHIP T)) +;;; for the function used to implement +;;; (DEFMETHOD PRINT-OBJECT ((SS STARSHIP) STREAM) ...). +;;; However, as of this writing (while defining/implementing it in +;;; sbcl-0.pre7.108) NAME is always a legal function name. +;;; +;;; If NAME is a legal function name, then the caller should be +;;; planning to set (FDEFINITION NAME) to the created function. +;;; (Otherwise the debug names will be inconsistent and thus +;;; unnecessarily confusing.) +(def-ir1-translator named-lambda ((name &rest rest) start cont) + (reference-leaf start + cont + (ir1-convert-lambda `(lambda ,@rest) + :source-name name))) ;;;; FUNCALL @@ -484,8 +514,8 @@ ;;; variables are marked as such. Context is the name of the form, for ;;; error reporting purposes. (declaim (ftype (function (list symbol) (values list list list)) - extract-let-variables)) -(defun extract-let-variables (bindings context) + extract-let-vars)) +(defun extract-let-vars (bindings context) (collect ((vars) (vals) (names)) @@ -521,7 +551,7 @@ Value forms. The variables are bound in parallel after all of the Values are evaluated." (multiple-value-bind (forms decls) (sb!sys:parse-body body nil) - (multiple-value-bind (vars values) (extract-let-variables bindings 'let) + (multiple-value-bind (vars values) (extract-let-vars bindings 'let) (let* ((*lexenv* (process-decls decls vars nil cont)) (fun-cont (make-continuation)) (fun (ir1-convert-lambda-body @@ -536,7 +566,7 @@ Similar to LET, but the variables are bound sequentially, allowing each Value form to reference any of the previous Vars." (multiple-value-bind (forms decls) (sb!sys:parse-body body nil) - (multiple-value-bind (vars values) (extract-let-variables bindings 'let*) + (multiple-value-bind (vars values) (extract-let-vars bindings 'let*) (let ((*lexenv* (process-decls decls vars nil cont))) (ir1-convert-aux-bindings start cont forms vars values))))) @@ -569,9 +599,8 @@ ;;; ;;; The function names are checked for legality. CONTEXT is the name ;;; of the form, for error reporting. -(declaim (ftype (function (list symbol) (values list list)) - extract-flet-variables)) -(defun extract-flet-variables (definitions context) +(declaim (ftype (function (list symbol) (values list list)) extract-flet-vars)) +(defun extract-flet-vars (definitions context) (collect ((names) (defs)) (dolist (def definitions) @@ -597,7 +626,7 @@ the lexically apparent function definition in the enclosing environment." (multiple-value-bind (forms decls) (sb!sys:parse-body body nil) (multiple-value-bind (names defs) - (extract-flet-variables definitions 'flet) + (extract-flet-vars definitions 'flet) (let* ((fvars (mapcar (lambda (n d) (ir1-convert-lambda d :source-name n @@ -606,7 +635,7 @@ names defs)) (*lexenv* (make-lexenv :default (process-decls decls nil fvars cont) - :functions (pairlis names fvars)))) + :funs (pairlis names fvars)))) (ir1-convert-progn-body start cont forms))))) (def-ir1-translator labels ((definitions &body body) start cont) @@ -617,7 +646,7 @@ each other." (multiple-value-bind (forms decls) (sb!sys:parse-body body nil) (multiple-value-bind (names defs) - (extract-flet-variables definitions 'labels) + (extract-flet-vars definitions 'labels) (let* (;; dummy LABELS functions, to be used as placeholders ;; during construction of real LABELS functions (placeholder-funs (mapcar (lambda (name) @@ -632,8 +661,7 @@ ;; the real LABELS functions, compiled in a LEXENV which ;; includes the dummy LABELS functions (real-funs - (let ((*lexenv* (make-lexenv - :functions placeholder-fenv))) + (let ((*lexenv* (make-lexenv :funs placeholder-fenv))) (mapcar (lambda (name def) (ir1-convert-lambda def :source-name name @@ -655,7 +683,7 @@ ;; placeholder used earlier) so that if the ;; lexical environment is used for inline ;; expansion we'll get the right functions. - :functions (pairlis names real-funs)))) + :funs (pairlis names real-funs)))) (ir1-convert-progn-body start cont forms)))))) ;;;; the THE special operator, and friends @@ -705,8 +733,9 @@ (when (and (not intersects) (not (policy *lexenv* (= inhibit-warnings 3)))) ;FIXME: really OK to suppress? - (compiler-warning - "The type ~S in ~S declaration conflicts with an enclosing assertion:~% ~S" + (compiler-warn + "The type ~S in ~S declaration conflicts with an ~ + enclosing assertion:~% ~S" (type-specifier ctype) name (type-specifier old-type))) @@ -743,17 +772,17 @@ ;;;; SETQ -;;; If there is a definition in LEXENV-VARIABLES, just set that, -;;; otherwise look at the global information. If the name is for a -;;; constant, then error out. +;;; If there is a definition in LEXENV-VARS, just set that, otherwise +;;; look at the global information. If the name is for a constant, +;;; then error out. (def-ir1-translator setq ((&whole source &rest things) start cont) (let ((len (length things))) (when (oddp len) (compiler-error "odd number of args to SETQ: ~S" source)) (if (= len 2) (let* ((name (first things)) - (leaf (or (lexenv-find name variables) - (find-free-variable name)))) + (leaf (or (lexenv-find name vars) + (find-free-var name)))) (etypecase leaf (leaf (when (constant-p leaf) @@ -765,10 +794,10 @@ (when (lambda-var-ignorep leaf) ;; ANSI's definition of "Declaration IGNORE, IGNORABLE" ;; requires that this be a STYLE-WARNING, not a full warning. - (compiler-style-warning + (compiler-style-warn "~S is being set even though it was declared to be ignored." name))) - (set-variable start cont leaf (second things))) + (setq-var start cont leaf (second things))) (cons (aver (eq (car leaf) 'MACRO)) (ir1-convert start cont `(setf ,(cdr leaf) ,(second things)))) @@ -783,7 +812,7 @@ ;;; This is kind of like REFERENCE-LEAF, but we generate a SET node. ;;; This should only need to be called in SETQ. -(defun set-variable (start cont var value) +(defun setq-var (start cont var value) (declare (type continuation start cont) (type basic-var var)) (let ((dest (make-continuation))) (setf (continuation-asserted-type dest) (leaf-type var)) @@ -792,7 +821,7 @@ (setf (continuation-dest dest) res) (setf (leaf-ever-used var) t) (push res (basic-var-sets var)) - (prev-link res dest) + (link-node-to-previous-continuation res dest) (use-continuation res cont)))) ;;;; CATCH, THROW and UNWIND-PROTECT @@ -837,7 +866,7 @@ ;;; ;;; Note that environment analysis replaces references to escape ;;; functions with references to the corresponding NLX-INFO structure. -(def-ir1-translator %escape-function ((tag) start cont) +(def-ir1-translator %escape-fun ((tag) start cont) (let ((fun (ir1-convert-lambda `(lambda () (return-from ,tag (%unknown-values))) @@ -848,8 +877,8 @@ ;;; Yet another special special form. This one looks up a local ;;; function and smashes it to a :CLEANUP function, as well as ;;; referencing it. -(def-ir1-translator %cleanup-function ((name) start cont) - (let ((fun (lexenv-find name functions))) +(def-ir1-translator %cleanup-fun ((name) start cont) + (let ((fun (lexenv-find name funs))) (aver (lambda-p fun)) (setf (functional-kind fun) :cleanup) (reference-leaf start cont fun))) @@ -870,13 +899,13 @@ `(block ,exit-block (%within-cleanup :catch - (%catch (%escape-function ,exit-block) ,tag) + (%catch (%escape-fun ,exit-block) ,tag) ,@body))))) ;;; UNWIND-PROTECT is similar to CATCH, but hairier. We make the ;;; cleanup forms into a local function so that they can be referenced ;;; both in the case where we are unwound and in any local exits. We -;;; use %CLEANUP-FUNCTION on this to indicate that reference by +;;; use %CLEANUP-FUN on this to indicate that reference by ;;; %UNWIND-PROTECT isn't "real", and thus doesn't cause creation of ;;; an XEP. (def-ir1-translator unwind-protect ((protected &body cleanup) start cont) @@ -896,15 +925,15 @@ `(flet ((,cleanup-fun () ,@cleanup nil)) ;; FIXME: If we ever get DYNAMIC-EXTENT working, then ;; ,CLEANUP-FUN should probably be declared DYNAMIC-EXTENT, - ;; and something can be done to make %ESCAPE-FUNCTION have + ;; and something can be done to make %ESCAPE-FUN have ;; dynamic extent too. (block ,drop-thru-tag (multiple-value-bind (,next ,start ,count) (block ,exit-tag (%within-cleanup :unwind-protect - (%unwind-protect (%escape-function ,exit-tag) - (%cleanup-function ,cleanup-fun)) + (%unwind-protect (%escape-fun ,exit-tag) + (%cleanup-fun ,cleanup-fun)) (return-from ,drop-thru-tag ,protected))) (,cleanup-fun) (%continue-unwind ,next ,start ,count))))))) @@ -941,7 +970,7 @@ (ir1-convert this-start this-cont arg) (setq this-start this-cont) (arg-conts this-cont))) - (prev-link node this-start) + (link-node-to-previous-continuation node this-start) (use-continuation node cont) (setf (basic-combination-args node) (arg-conts)))))) @@ -1047,9 +1076,9 @@ (ecase (info :function :kind name) ((nil)) (:function - (remhash name *free-functions*) + (remhash name *free-funs*) (undefine-fun-name name) - (compiler-warning + (compiler-warn "~S is being redefined as a macro when it was ~ previously ~(~A~) to be a function." name