Skip to content
GitLab
Menu
Projects
Groups
Snippets
Loading...
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Contribute to GitLab
Sign in / Register
Toggle navigation
Menu
Open sidebar
cmucl
cmucl
Commits
a9efa4b5
Commit
a9efa4b5
authored
Sep 10, 1993
by
wlott
Browse files
Added support for &more args
parent
69854c4d
Changes
7
Hide whitespace changes
Inline
Side-by-side
compiler/ctype.lisp
View file @
a9efa4b5
...
...
@@ -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.2
7
1993/0
8/25 00:14:59 ram
Exp $"
)
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/ctype.lisp,v 1.2
8
1993/0
9/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*
)
...
...
compiler/debug-dump.lisp
View file @
a9efa4b5
...
...
@@ -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.3
8
1993/0
8/25 00:15:01 ram
Exp $"
)
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/debug-dump.lisp,v 1.3
9
1993/0
9/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
)
...
...
compiler/ir1tran.lisp
View file @
a9efa4b5
...
...
@@ -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.10
1
1993/0
8/24 02:12
:0
6
wlott Exp $"
)
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/ir1tran.lisp,v 1.10
2
1993/0
9/10 19:09
:0
9
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
)))))))
...
...
compiler/locall.lisp
View file @
a9efa4b5
...
...
@@ -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.4
1
1993/0
5/08 00:42:36 ram
Exp $"
)
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/locall.lisp,v 1.4
2
1993/0
9/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-"
)))
...
...
compiler/node.lisp
View file @
a9efa4b5
...
...
@@ -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.3
1
1993/0
8/21 09:57:25 ram
Exp $"
)
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/node.lisp,v 1.3
2
1993/0
9/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
...
...
compiler/proclaim.lisp
View file @
a9efa4b5
...
...
@@ -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.2
8
1993/0
3
/1
6 01:52:26 ram
Exp $"
)
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/proclaim.lisp,v 1.2
9
1993/0
9
/1
0 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 e
ight
values:
;;; Break a lambda-list into its component parts. We return e
leven
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
...
...
compiler/typetran.lisp
View file @
a9efa4b5
...
...
@@ -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.2
4
1993/0
8
/1
9 21:03:39 ram
Exp $"
)
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/typetran.lisp,v 1.2
5
1993/0
9
/1
0 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 ~
...
...
Write
Preview
Markdown
is supported
0%
Try again
or
attach a new file
.
Attach a file
Cancel
You are about to add
0
people
to the discussion. Proceed with caution.
Finish editing this message first!
Cancel
Please
register
or
sign in
to comment