diff --git a/code/fdefinition.lisp b/code/fdefinition.lisp index a0df30aad33383d254b2f046ad27f02e2b304304..27bb489f5b6494d36e3347170f68123361b830e9 100644 --- a/code/fdefinition.lisp +++ b/code/fdefinition.lisp @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/fdefinition.lisp,v 1.21 2003/02/16 19:05:19 emarsden Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/fdefinition.lisp,v 1.22 2003/03/31 11:13:23 gerd Exp $") ;;; ;;; ********************************************************************** ;;; @@ -95,6 +95,11 @@ (when (eql 2 (length name)) (valid-function-name-p (second name)))) +(define-function-name-syntax flet (name) + (valid-function-name-p (cadr name))) + +(define-function-name-syntax labels (name) + (valid-function-name-p (cadr name))) ;;;; Fdefinition (fdefn) objects. diff --git a/compiler/ir1tran.lisp b/compiler/ir1tran.lisp index f23e3ebebf3a8e0d0432cdaed5fd5473be240ec2..d12210197df75fad547572541d9bcfccf28768df 100644 --- a/compiler/ir1tran.lisp +++ b/compiler/ir1tran.lisp @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/ir1tran.lisp,v 1.140 2003/03/30 00:41:07 gerd Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/ir1tran.lisp,v 1.141 2003/03/31 11:13:22 gerd Exp $") ;;; ;;; ********************************************************************** ;;; @@ -110,6 +110,12 @@ ;;; (defvar *compile-time-define-macros* t) +;;; Stack (alist) of names of currently compiled functions and counters +;;; how often a name has been used. +;;; +(declaim (list *current-function-names*)) +(defvar *current-function-names* ()) + (defvar *derive-function-types* t "If true, argument and result type information derived from compilation of DEFUNs is used when compiling calls to that function. If false, only @@ -218,7 +224,7 @@ ;;; (defun find-lexically-apparent-function (name context) (declare (string context) (values leaf)) - (let ((var (lexenv-find name functions :test #'equal))) + (let ((var (lexenv-find-function name))) (cond (var (unless (leaf-p var) (assert (and (consp var) (eq (car var) 'macro))) @@ -520,7 +526,7 @@ (declaim (start-block ir1-convert ir1-convert-progn-body ir1-convert-combination-args reference-leaf reference-constant)) - + ;;; IR1-Convert -- Interface ;;; ;;; Translate Form into IR1. The code is inserted as the Next of the @@ -548,7 +554,7 @@ (let ((fun (car form))) (cond ((symbolp fun) - (let ((lexical-def (lexenv-find fun functions))) + (let ((lexical-def (lexenv-find-function fun))) (typecase lexical-def (null (ir1-convert-global-functoid start cont form)) (functional @@ -1978,11 +1984,16 @@ (compiler-error "Lambda-list absent or not a list:~% ~S" form)) (multiple-value-bind (vars keyp allow-other-keys aux-vars aux-vals) - (find-lambda-vars (cadr form)) - (multiple-value-bind - (body decls) + (find-lambda-vars (cadr form)) + (multiple-value-bind (body decls) (system:parse-body (cddr form) *lexical-environment* t) - (let* ((context-decls + (let* ((*current-function-names* + (if (member parent-form + '(flet labels defun defmacro define-compiler-macro) + :test #'eq) + (list name) + *current-function-names*)) + (context-decls (and parent-form (loop for fun in *context-declarations* append (funcall (the function fun) @@ -2282,9 +2293,10 @@ (environment (gensym))) (collect ((new-fenv)) (dolist (def definitions) - (let ((name (first def)) - (arglist (second def)) - (body (cddr def))) + (let* ((name (first def)) + (*current-function-names* (list name)) + (arglist (second def)) + (body (cddr def))) (multiple-value-bind (body local-decs) (lisp::parse-defmacro arglist whole body name 'macrolet @@ -2839,22 +2851,33 @@ ;;; (defun extract-flet-variables (definitions context) (declare (list definitions) (symbol context) (values list list)) - (collect ((names) - (defs)) - (dolist (def definitions) - (when (or (atom def) (< (length def) 2)) - (compiler-error "Malformed ~S definition spec: ~S." context def)) - - (let ((name (check-function-name (first def))) - (block-name (nth-value 1 (valid-function-name-p (first def))))) - (names name) - (multiple-value-bind (body decls) - (system:parse-body (cddr def) *lexical-environment* t) - (defs `(lambda ,(second def) - ,@decls - (block ,block-name - . ,body)))))) - (values (names) (defs)))) + (flet ((local-function-name (name) + (let ((base (list context name)) + (current *current-function-names*)) + (if current + (let ((entry (assoc name (cdr current) :test #'equal))) + (cond (entry + (nconc base (list (incf (cdr entry))) + (list (car current)))) + (t + (push (cons name 0) (cdr current)) + (nconc base (list (car current)))))) + base)))) + (collect ((names) (defs)) + (dolist (def definitions) + (when (or (atom def) (< (length def) 2)) + (compiler-error "Malformed ~S definition spec: ~S." context def)) + (let* ((name (check-function-name (first def))) + (block-name (nth-value 1 (valid-function-name-p (first def)))) + (local-name (local-function-name name))) + (names local-name) + (multiple-value-bind (body decls) + (system:parse-body (cddr def) *lexical-environment* t) + (defs `(lambda ,(second def) + ,@decls + (block ,block-name + . ,body)))))) + (values (names) (defs))))) (def-ir1-translator flet ((definitions &body (body decls)) @@ -3120,7 +3143,7 @@ ;;; 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))) + (let ((fun (lexenv-find-function name))) (assert (lambda-p fun)) (setf (functional-kind fun) :cleanup) (reference-leaf start cont fun))) diff --git a/compiler/macros.lisp b/compiler/macros.lisp index b0cf197c0106347993b50ce45f231ef4272acfd1..7db22e4cf23a0e2e9af282ad2b0fb04d93782a4e 100644 --- a/compiler/macros.lisp +++ b/compiler/macros.lisp @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/macros.lisp,v 1.48 2002/12/03 16:58:55 toy Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/macros.lisp,v 1.49 2003/03/31 11:13:22 gerd Exp $") ;;; ;;; ********************************************************************** ;;; @@ -735,6 +735,19 @@ (values (cdr ,n-res) t) (values nil nil)))) +;;; +;;; LEXENV-FIND-FUNCTION -- Interface +;;; +;;; Find local function with name NAME in *LEXICAL-ENVIRONMENT*. +;;; +(defun lexenv-find-function (name) + (lexenv-find name functions + :test (lambda (x y) + (or (equal x y) + (and (consp y) + (member (car y) '(flet labels)) + (equal x (cadr y))))))) + ;;; With-debug-counters -- Interface diff --git a/compiler/main.lisp b/compiler/main.lisp index 442bb1b041ac337b43ea5b979d0985af3b2a3f31..51e1330302d905466983be7a0a839494c581b349 100644 --- a/compiler/main.lisp +++ b/compiler/main.lisp @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/main.lisp,v 1.132 2003/02/05 19:32:21 emarsden Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/main.lisp,v 1.133 2003/03/31 11:13:22 gerd Exp $") ;;; ;;; ********************************************************************** ;;; @@ -1883,7 +1883,8 @@ (*last-format-args* nil) (*last-message-count* 0) (*compile-object* (make-core-object)) - (*gensym-counter* 0)) + (*gensym-counter* 0) + (*current-function-names* (list name))) (with-debug-counters (clear-stuff) (find-source-paths form 0) diff --git a/general-info/release-19a.txt b/general-info/release-19a.txt index d4e1f153030693ef87b34fda5eda62afaccc510f..e9e4dcfbad44c92eb4dbac6d7a69a956a2c2316e 100644 --- a/general-info/release-19a.txt +++ b/general-info/release-19a.txt @@ -26,6 +26,8 @@ New in this release: necessary to SHADOWING-IMPORT these from PCL when doing MOP programming, and it fixes some non-compliances as well. - Weak hash tables have been added for x86 systems. + - Local functions are now named (FLET <name> ...) or + (LABELS <name> ...). * Numerous ANSI compliance fixes: @@ -40,6 +42,8 @@ New in this release: - PCL's class hierarchy has been changed to conform to AMOP, for instance, GENERIC-FUNCTION is now a subclass of STANDARD-OBJECT. + - ENSURE-CLASS-USING-CLASS's argument list has been changed + to conform to AMOP. * Improvements to Hemlock, the Emacs-like editor: diff --git a/pcl/walk.lisp b/pcl/walk.lisp index 1f9ce8297969eee53c2adafc46784f3f046c5651..6673aab67d34df34c4baa730c0604964e35c421a 100644 --- a/pcl/walk.lisp +++ b/pcl/walk.lisp @@ -26,7 +26,7 @@ ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/walk.lisp,v 1.24 2003/03/22 16:15:15 gerd Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/walk.lisp,v 1.25 2003/03/31 11:13:22 gerd Exp $") ;;; ;;; A simple code walker, based IN PART on: (roll the credits) ;;; Larry Masinter's Masterscope @@ -188,15 +188,6 @@ (coerce (cadr m) 'function))) macros))))) -#-gerd-flet-names -(defun environment-function (env fn) - (when env - (let ((entry (assoc fn (c::lexenv-functions env) :test #'equal))) - (and entry - (c::functional-p (cdr entry)) - (cdr entry))))) - -#+gerd-flet-names (defun environment-function (env fn) (when env (flet ((test (x y)