From cf2412bd1d5d9beb0c7863fb31b4ce5624cf488f Mon Sep 17 00:00:00 2001 From: Jan Moringen Date: Wed, 21 Oct 2015 20:34:23 +0200 Subject: [PATCH] Style improvements and minor bugfix from sb-fasteval integration. --- src/code/defboot.lisp | 30 +++++++++++++++--------------- src/code/inspect.lisp | 40 ++++++++++++++++++++-------------------- src/compiler/info-functions.lisp | 4 ++-- src/compiler/target-main.lisp | 31 ++++++++++++++++++------------- 4 files changed, 55 insertions(+), 50 deletions(-) diff --git a/src/code/defboot.lisp b/src/code/defboot.lisp index 690586131..f5d2dfbc1 100644 --- a/src/code/defboot.lisp +++ b/src/code/defboot.lisp @@ -262,27 +262,27 @@ evaluated as a PROGN." ;; and no need to call NOTE-NAME-DEFINED. It would do nothing. )) -;; Return T if SEXPR is the lambda expression that corresponds -;; to the structure slot reader for SLOT-INFO so that we can decide -;; that an interpreted lambda is consistent with its source-transform. -;; I think there's actually a better way than this heuristic: *always* remove -;; a source-transform whenever an fdefn-fun is set, with a blanket exception -;; for boostrap code. Then %TARGET-DEFSTRUCT, which is the last step to occur -;; from DEFSTRUCT, can re-establish the source-transforms. +;; Return T if LAMBDA-LIST and FORMS make up to the lambda expression +;; that corresponds to the structure slot accessor for SLOT-INFO so +;; that we can decide that an interpreted lambda is consistent with +;; its source-transform. I think there's actually a better way than +;; this heuristic: *always* remove a source-transform whenever an +;; fdefn-fun is set, with a blanket exception for boostrap code. Then +;; %TARGET-DEFSTRUCT, which is the last step to occur from DEFSTRUCT, +;; can re-establish the source-transforms. (defun structure-accessor-form-p (kind slot-info lambda-list forms) - (if (and (equal lambda-list - (if (eq kind :read) '(instance) '(sb!kernel::value instance))) - (singleton-p forms)) + (let ((expected-lambda-list + (ecase kind + (:read '(instance)) + (:write '(sb!kernel::value instance))))) + (when (and (equal lambda-list expected-lambda-list) + (singleton-p forms)) (let ((form (car forms))) ;; FORM must match (BLOCK x subform) (and (typep form '(cons (eql block) (cons t (cons t null)))) (equal (third form) (slot-access-transform - kind - (if (eq kind :read) - '(instance) - '(instance sb!kernel::value)) - slot-info)))))) + kind (reverse expected-lambda-list) slot-info))))))) ;;;; DEFVAR and DEFPARAMETER diff --git a/src/code/inspect.lisp b/src/code/inspect.lisp index a37dcc3c4..5700df5fa 100644 --- a/src/code/inspect.lisp +++ b/src/code/inspect.lisp @@ -226,30 +226,30 @@ evaluated expressions. #+sb-eval (defmethod inspected-parts ((object sb-eval:interpreted-function)) (multiple-value-bind (defn closurep name) (function-lambda-expression object) - (declare (ignore closurep)) - (values (format nil "The object is an interpreted function named ~S.~%" name) - t - ;; Defined-from stuff used to be here. Someone took - ;; it out. FIXME: We should make it easy to get - ;; to DESCRIBE from the inspector. - (list - (cons "Lambda-list" (sb-eval:interpreted-function-lambda-list object)) - (cons "Definition" (function-lambda-expression object)) - (cons "Documentation" (sb-eval:interpreted-function-documentation object)))))) + (declare (ignore closurep)) + (values (format nil "The object is an interpreted function named ~S.~%" name) + t + ;; Defined-from stuff used to be here. Someone took + ;; it out. FIXME: We should make it easy to get + ;; to DESCRIBE from the inspector. + (list + (cons "Lambda-list" (sb-eval:interpreted-function-lambda-list object)) + (cons "Definition" defn) + (cons "Documentation" (sb-eval:interpreted-function-documentation object)))))) #+sb-fasteval (defmethod inspected-parts ((object sb-interpreter:interpreted-function)) (multiple-value-bind (defn closurep name) (function-lambda-expression object) - (declare (ignore closurep)) - (values (format nil "The object is an interpreted function named ~S.~%" name) - t - ;; Defined-from stuff used to be here. Someone took - ;; it out. FIXME: We should make it easy to get - ;; to DESCRIBE from the inspector. - (list - (cons "Lambda-list" (sb-interpreter:fun-lambda-list object)) - (cons "Definition" defn) - (cons "Documentation" (sb-interpreter:fun-docstring object)))))) + (declare (ignore closurep)) + (values (format nil "The object is an interpreted function named ~S.~%" name) + t + ;; Defined-from stuff used to be here. Someone took + ;; it out. FIXME: We should make it easy to get + ;; to DESCRIBE from the inspector. + (list + (cons "Lambda-list" (sb-interpreter:fun-lambda-list object)) + (cons "Definition" defn) + (cons "Documentation" (sb-interpreter:fun-docstring object)))))) (defmethod inspected-parts ((object vector)) (values (format nil diff --git a/src/compiler/info-functions.lisp b/src/compiler/info-functions.lisp index 95af0949d..d5baa3a57 100644 --- a/src/compiler/info-functions.lisp +++ b/src/compiler/info-functions.lisp @@ -147,12 +147,12 @@ only." (multiple-value-bind (kind def) (sb!interpreter:find-lexical-fun env symbol) (when def - (return-from sb!xc:macro-function (if (eq kind :macro) def))))) + (return-from sb!xc:macro-function (when (eq kind :macro) def))))) (lexenv (let ((def (cdr (assoc symbol (lexenv-funs env))))) (when def (return-from sb!xc:macro-function - (if (typep def '(cons (eql macro))) (cdr def))))))) + (when (typep def '(cons (eql macro))) (cdr def))))))) (values (info :function :macro-function symbol))) (defun (setf sb!xc:macro-function) (function symbol &optional environment) diff --git a/src/compiler/target-main.lisp b/src/compiler/target-main.lisp index 6c7b89c0f..60fe652b2 100644 --- a/src/compiler/target-main.lisp +++ b/src/compiler/target-main.lisp @@ -123,27 +123,32 @@ (defun compile-in-lexenv (name definition lexenv &optional source-info tlf errorp) - (multiple-value-bind (compiled-definition warnings-p failure-p) - (block nil + (dx-flet ((really-compile (definition lexenv) + (actually-compile + name definition lexenv source-info tlf errorp))) + (multiple-value-bind (compiled-definition warnings-p failure-p) (typecase definition #!+sb-fasteval (sb!interpreter:interpreted-function - (multiple-value-setq (definition lexenv) + (multiple-value-call #'really-compile (sb!interpreter:prepare-for-compile definition))) #!+sb-eval (sb!eval:interpreted-function - (multiple-value-setq (definition lexenv) + (multiple-value-call #'really-compile (sb!eval:prepare-for-compile definition))) (function - (return (values definition nil nil)))) - (actually-compile name definition lexenv source-info tlf errorp)) - (aver (typep compiled-definition 'compiled-function)) - (values (if (not name) - compiled-definition - (progn (if (and (symbolp name) (macro-function name)) - (setf (macro-function name) compiled-definition) - (setf (fdefinition name) compiled-definition)) - name)) warnings-p failure-p))) + (values definition nil nil)) + (t + (really-compile definition lexenv))) + (aver (typep compiled-definition 'compiled-function)) + (let ((result (if (not name) + compiled-definition + (progn + (if (and (symbolp name) (macro-function name)) + (setf (macro-function name) compiled-definition) + (setf (fdefinition name) compiled-definition)) + name)))) + (values result warnings-p failure-p))))) (defun compile (name &optional (definition (or (and (symbolp name) (macro-function name)) -- 2.11.4.GIT