From 45c5ada96a7cd910e9a811d7228f12e7b28f1306 Mon Sep 17 00:00:00 2001 From: ram <ram> Date: Thu, 11 Oct 1990 18:18:16 +0000 Subject: [PATCH] Made DEFTYPE warn if redefining a structure and flame if a primitive type. Fixed it to test FBOUNDP on the right symbol so that %NOTE-TYPE-DEFINED can get called. Changed %%DEFUN to use DEFINE-FUNCTION-NAME and also to blow away any assumed type info. --- code/macros.lisp | 23 ++++++++++++++--------- 1 file changed, 14 insertions(+), 9 deletions(-) diff --git a/code/macros.lisp b/code/macros.lisp index bab3ad1e6..96eba6f6d 100644 --- a/code/macros.lisp +++ b/code/macros.lisp @@ -7,7 +7,7 @@ ;;; Scott Fahlman (FAHLMAN@CMUC). ;;; ********************************************************************** ;;; -;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/macros.lisp,v 1.11 1990/09/06 19:43:28 wlott Exp $ +;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/macros.lisp,v 1.12 1990/10/11 18:18:16 ram Exp $ ;;; ;;; This file contains the macros that are part of the standard ;;; Spice Lisp environment. @@ -219,6 +219,13 @@ (member :new-compiler *features*)) (setf (get name 'deftype-expander) expander)) + (ecase (info type kind name) + (:primitive + (error "Illegal to redefine standard type: ~S." name)) + (:structure + (warn "Redefining structure type ~S with DEFTYPE." name) + (c::undefine-structure (info type structure-info name))) + ((nil :defined))) (when #-new-compiler *bootstrap-deftype* #+new-compiler t (setf (info type kind name) :defined) (setf (info type expander name) expander)) @@ -226,7 +233,7 @@ (setf (documentation name 'type) doc)) ;; ### Bootstrap hack -- we need to define types before %note-type-defined ;; is defined. - (when (fboundp 'c::note-type-defined) + (when (fboundp 'c::%note-type-defined) (c::%note-type-defined name)) name) @@ -295,13 +302,11 @@ (if (and (consp name) (eq (first name) 'setf)) (setf (documentation (second name) 'setf) doc) (setf (documentation name 'function) doc))) - - (unless (eq (info function kind name) :function) - (setf (info function kind name) :function)) - - (when (info function accessor-for name) - (setf (info function accessor-for name) nil)) - + (c::define-function-name name) + (when (eq (info function where-from name) :assumed) + (setf (info function where-from name) :defined) + (when (info function assumed-type name) + (setf (info function assumed-type name) nil))) (when (or inline-expansion (info function inline-expansion name)) (setf (info function inline-expansion name) inline-expansion)) -- GitLab