diff --git a/compiler/ctype.lisp b/compiler/ctype.lisp index ac87a9e3a6f9d36969839ae181c345e12eca821f..2abe7a253456f229b73ad460f7d87c61a58733f5 100644 --- a/compiler/ctype.lisp +++ b/compiler/ctype.lisp @@ -7,7 +7,7 @@ ;;; Scott Fahlman or slisp-group@cs.cmu.edu. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/ctype.lisp,v 1.27 1993/08/25 00:14:59 ram Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/ctype.lisp,v 1.28 1993/09/10 19:09:04 wlott Exp $") ;;; ;;; ********************************************************************** ;;; @@ -300,8 +300,9 @@ (:keyword (keys (make-key-info :name (arg-info-keyword info) :type type))) - (:rest - (setq rest *universal-type*))) + ((:rest :more-context) + (setq rest *universal-type*)) + (:more-count)) (req type)))) (make-function-type @@ -671,7 +672,13 @@ (res (type-union (pop opt) (or def-type *universal-type*)))) (:rest (when (function-type-rest type) - (res (specifier-type 'list))))) + (res (specifier-type 'list)))) + (:more-context + (when (function-type-rest type) + (res *universal-type*))) + (:more-count + (when (function-type-rest type) + (res (specifier-type 'fixnum))))) (vars arg) (when (arg-info-supplied-p info) (res *universal-type*) diff --git a/compiler/debug-dump.lisp b/compiler/debug-dump.lisp index 43b9cf5b400b23821ec3f6032608a22c2d09e26c..820f8b02cac4c07f668c3df44cbc27343ec76892 100644 --- a/compiler/debug-dump.lisp +++ b/compiler/debug-dump.lisp @@ -7,7 +7,7 @@ ;;; Scott Fahlman or slisp-group@cs.cmu.edu. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/debug-dump.lisp,v 1.38 1993/08/25 00:15:01 ram Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/debug-dump.lisp,v 1.39 1993/09/10 19:09:07 wlott Exp $") ;;; ;;; ********************************************************************** ;;; @@ -522,6 +522,8 @@ (res (arg-info-keyword info))) (:rest (res 'rest-arg)) + (:more-context + (res 'more-arg)) (:optional (unless saw-optional (res 'optional-args) diff --git a/compiler/ir1tran.lisp b/compiler/ir1tran.lisp index 7714d18a1d974f39dd9e52153548d9cec2dd71d1..c503b430e439c26f0c6ad1be36890a8b56139b6d 100644 --- a/compiler/ir1tran.lisp +++ b/compiler/ir1tran.lisp @@ -7,7 +7,7 @@ ;;; Scott Fahlman or slisp-group@cs.cmu.edu. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/ir1tran.lisp,v 1.101 1993/08/24 02:12:06 wlott Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/ir1tran.lisp,v 1.102 1993/09/10 19:09:09 wlott Exp $") ;;; ;;; ********************************************************************** ;;; @@ -1263,8 +1263,10 @@ (proclaim '(function find-lambda-vars (list) (values list boolean boolean list list))) (defun find-lambda-vars (list) - (multiple-value-bind (required optional restp rest keyp keys allowp aux) - (parse-lambda-list list) + (multiple-value-bind + (required optional restp rest keyp keys allowp aux + morep more-context more-count) + (parse-lambda-list list) (collect ((vars) (names-so-far) (aux-vars) @@ -1307,6 +1309,18 @@ (setf (lambda-var-arg-info var) (make-arg-info :kind :rest)) (vars var) (names-so-far rest))) + + (when morep + (let ((var (varify-lambda-arg more-context (names-so-far)))) + (setf (lambda-var-arg-info var) + (make-arg-info :kind :more-context)) + (vars var) + (names-so-far more-context)) + (let ((var (varify-lambda-arg more-count (names-so-far)))) + (setf (lambda-var-arg-info var) + (make-arg-info :kind :more-count)) + (vars var) + (names-so-far more-count))) (dolist (spec keys) (cond @@ -1609,7 +1623,7 @@ ;;; the compilation policy over to the interface policy, so that keyword args ;;; will be checked even when type checking isn't on in general. ;;; -(defun convert-more-entry (res entry-vars entry-vals rest keys) +(defun convert-more-entry (res entry-vars entry-vals rest morep keys) (declare (type optional-dispatch res) (list entry-vars entry-vals keys)) (collect ((arg-vars) (arg-vals (reverse entry-vals)) @@ -1635,6 +1649,9 @@ (when rest (arg-vals `(%listify-rest-args ,n-context ,n-count))) + (when morep + (arg-vals n-context) + (arg-vals n-count)) (when (optional-dispatch-keyp res) (let ((n-index (gensym)) @@ -1725,8 +1742,8 @@ ;;; entry's argument. ;;; (defun ir1-convert-more (res default-vars default-vals entry-vars entry-vals - rest keys supplied-p-p body aux-vars aux-vals - cont) + rest more-context more-count keys supplied-p-p + body aux-vars aux-vals cont) (declare (type optional-dispatch res) (list default-vars default-vals entry-vars entry-vals keys body aux-vars aux-vals) @@ -1738,6 +1755,11 @@ (when rest (main-vars rest) (main-vals '())) + (when more-context + (main-vars more-context) + (main-vals nil) + (main-vars more-count) + (main-vals 0)) (dolist (key keys) (let* ((info (lambda-var-arg-info key)) @@ -1783,7 +1805,7 @@ (last-entry (convert-optional-entry main-entry default-vars (main-vals) ()))) (setf (optional-dispatch-main-entry res) main-entry) - (convert-more-entry res entry-vars entry-vals rest keys) + (convert-more-entry res entry-vars entry-vals rest more-context keys) (push (if supplied-p-p (convert-optional-entry last-entry entry-vars entry-vals ()) @@ -1840,7 +1862,7 @@ ;; Handle &key with no keys... (ir1-convert-more res default-vars default-vals entry-vars entry-vals - nil vars supplied-p-p body aux-vars + nil nil nil vars supplied-p-p body aux-vars aux-vals cont) (let ((fun (ir1-convert-lambda-body body (reverse default-vars) aux-vars aux-vals t cont))) @@ -1875,12 +1897,17 @@ (:rest (ir1-convert-more res default-vars default-vals entry-vars entry-vals - arg (rest vars) supplied-p-p body + arg nil nil (rest vars) supplied-p-p body aux-vars aux-vals cont)) + (:more-context + (ir1-convert-more res default-vars default-vals + entry-vars entry-vals + nil arg (second vars) (cddr vars) supplied-p-p + body aux-vars aux-vals cont)) (:keyword (ir1-convert-more res default-vars default-vals entry-vars entry-vals - nil vars supplied-p-p body aux-vars + nil nil nil vars supplied-p-p body aux-vars aux-vals cont))))))) diff --git a/compiler/locall.lisp b/compiler/locall.lisp index ae356e0405479ba9f876cbef25dab864227e7053..fad7c8fbba2aad4c897b52ecba3ed1180291dc67 100644 --- a/compiler/locall.lisp +++ b/compiler/locall.lisp @@ -7,7 +7,7 @@ ;;; Scott Fahlman or slisp-group@cs.cmu.edu. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/locall.lisp,v 1.41 1993/05/08 00:42:36 ram Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/locall.lisp,v 1.42 1993/09/10 19:09:16 wlott Exp $") ;;; ;;; ********************************************************************** ;;; @@ -559,7 +559,11 @@ (ecase (arg-info-kind info) (:keyword (key-vars var)) - ((:rest :optional)))))) + ((:rest :optional)) + ((:more-context :more-count) + (compiler-warning "Can't local-call functions with &MORE args.") + (setf (basic-combination-kind call) :error) + (return-from convert-more-call)))))) (dotimes (i max) (temps (gensym "FIXED-ARG-TEMP-"))) diff --git a/compiler/node.lisp b/compiler/node.lisp index 0bd41be27a8e6f073eed8293081b08b8b4540434..f26703d1738f5863993cb14f9b26cf651239c5c7 100644 --- a/compiler/node.lisp +++ b/compiler/node.lisp @@ -7,7 +7,7 @@ ;;; Scott Fahlman or slisp-group@cs.cmu.edu. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/node.lisp,v 1.31 1993/08/21 09:57:25 ram Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/node.lisp,v 1.32 1993/09/10 19:09:18 wlott Exp $") ;;; ;;; ********************************************************************** ;;; @@ -1042,7 +1042,8 @@ ;; ;; The kind of argument being described. Required args only have arg ;; info structures if they are special. - (kind (required-argument) :type (member :required :optional :keyword :rest)) + (kind (required-argument) :type (member :required :optional :keyword :rest + :more-context :more-count)) ;; ;; If true, the Var for supplied-p variable of a keyword or optional arg. ;; This is true for keywords with non-constant defaults even when there is no diff --git a/compiler/proclaim.lisp b/compiler/proclaim.lisp index 6a652539bd6351569a4ab1a65207086eaab039e4..51c84b5b3f2ad2d7e6b35b8043b4593fe7743b08 100644 --- a/compiler/proclaim.lisp +++ b/compiler/proclaim.lisp @@ -7,7 +7,7 @@ ;;; Scott Fahlman or slisp-group@cs.cmu.edu. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/proclaim.lisp,v 1.28 1993/03/16 01:52:26 ram Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/proclaim.lisp,v 1.29 1993/09/10 19:09:22 wlott Exp $") ;;; ;;; ********************************************************************** ;;; @@ -23,11 +23,11 @@ (export '(inhibit-warnings freeze-type optimize-interface constant-function)) (in-package "KERNEL") (export '(note-name-defined define-function-name undefine-function-name - *type-system-initialized* %note-type-defined)) + *type-system-initialized* %note-type-defined)) (in-package "LISP") (export '(declaim proclaim)) (in-package "C") - +(export '(&more)) ;;; True if the type system has been properly initialized, and thus is o.k. to ;;; use. @@ -95,7 +95,7 @@ ;;; Parse-Lambda-List -- Interface ;;; -;;; Break a lambda-list into its component parts. We return eight values: +;;; Break a lambda-list into its component parts. We return eleven values: ;;; 1] A list of the required args. ;;; 2] A list of the optional arg specs. ;;; 3] True if a rest arg was specified. @@ -104,13 +104,17 @@ ;;; 6] A list of the keyword arg specs. ;;; 7] True if &allow-other-keys was specified. ;;; 8] A list of the &aux specifiers. +;;; 9] True if a more arg was specified. +;;; 10] The &more context var +;;; 11] The &more count var ;;; ;;; The top-level lambda-list syntax is checked for validity, but the arg ;;; specifiers are just passed through untouched. If something is wrong, we ;;; use Compiler-Error, aborting compilation to the last recovery point. ;;; (proclaim '(function parse-lambda-list (list) - (values list list boolean t boolean list boolean list))) + (values list list boolean t boolean list boolean list + boolean t t))) (defun parse-lambda-list (list) (collect ((required) (optional) @@ -118,6 +122,9 @@ (aux)) (let ((restp nil) (rest nil) + (morep nil) + (more-context nil) + (more-count nil) (keyp nil) (allowp nil) (state :required)) @@ -135,8 +142,13 @@ (unless (member state '(:required &optional)) (compiler-error "Misplaced &rest in lambda-list: ~S." list)) (setq state '&rest)) + (&more + (unless (member state '(:required &optional)) + (compiler-error "Misplaced &more in lambda-list: ~S." list)) + (setq morep t state '&more-context)) (&key - (unless (member state '(:required &optional :post-rest)) + (unless (member state '(:required &optional :post-rest + :post-more)) (compiler-error "Misplaced &key in lambda-list: ~S." list)) (setq keyp t) (setq state '&key)) @@ -145,7 +157,7 @@ (compiler-error "Misplaced &allow-other-keys in lambda-list: ~S." list)) (setq allowp t state '&allow-other-keys)) (&aux - (when (eq state '&rest) + (when (member state '(&rest &more-context &more-count)) (compiler-error "Misplaced &aux in lambda-list: ~S." list)) (setq state '&aux)) (t @@ -155,11 +167,17 @@ (&optional (optional arg)) (&rest (setq restp t rest arg state :post-rest)) + (&more-context + (setq more-context arg state '&more-count)) + (&more-count + (setq more-count arg state :post-more)) (&key (keys arg)) (&aux (aux arg)) (t (compiler-error "Found garbage in lambda-list when expecting a keyword: ~S." arg))))) - (values (required) (optional) restp rest keyp (keys) allowp (aux))))) + + (values (required) (optional) restp rest keyp (keys) allowp (aux) + morep more-context more-count)))) ;;; Check-Function-Name -- Interface diff --git a/compiler/typetran.lisp b/compiler/typetran.lisp index 45e434e5e44d39d715dfb277f0781b9440d4081e..aa8b3a1086139177feedb7621319f0b7d0798fc1 100644 --- a/compiler/typetran.lisp +++ b/compiler/typetran.lisp @@ -7,7 +7,7 @@ ;;; Scott Fahlman or slisp-group@cs.cmu.edu. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/typetran.lisp,v 1.24 1993/08/19 21:03:39 ram Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/typetran.lisp,v 1.25 1993/09/10 19:09:23 wlott Exp $") ;;; ;;; ********************************************************************** ;;; @@ -366,9 +366,12 @@ nil)))) (multiple-value-bind (pred get-layout) - (if (csubtypep class (specifier-type 'funcallable-instance)) - (values 'funcallable-instance-p '%funcallable-instance-layout) - (values '%instancep '%instance-layout)) + (cond ((csubtypep class (specifier-type 'instance)) + (values '%instancep '%instance-layout)) + ((csubtypep class (specifier-type 'funcallable-instance)) + (values 'funcallable-instance-p '%funcallable-instance-layout)) + (t + (values '(lambda (x) (declare (ignore x)) t) 'layout-of))) (cond ((not (and name (eq (find-class name) class))) (compiler-error "Can't compile TYPEP of anonymous or undefined ~