Commit a9efa4b5 authored by wlott's avatar wlott
Browse files

Added support for &more args

parent 69854c4d
......@@ -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*)
......
......@@ -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)
......
......@@ -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)))))))
......
......@@ -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-")))
......
......@@ -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
......
......@@ -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
......
......@@ -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 ~
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment