Skip to content
GitLab
Explore
Sign in
Register
Primary navigation
Search or go to…
Project
cmucl
Manage
Activity
Members
Labels
Plan
Issues
Issue boards
Milestones
Wiki
Code
Merge requests
Repository
Branches
Commits
Tags
Repository graph
Compare revisions
Snippets
Build
Pipelines
Jobs
Pipeline schedules
Artifacts
Deploy
Releases
Package registry
Model registry
Operate
Environments
Terraform modules
Monitor
Incidents
Service Desk
Analyze
Value stream analytics
Contributor analytics
CI/CD analytics
Repository analytics
Model experiments
Help
Help
Support
GitLab documentation
Compare GitLab plans
Community forum
Contribute to GitLab
Provide feedback
Terms and privacy
Keyboard shortcuts
?
Snippets
Groups
Projects
Show more breadcrumbs
Carl Shapiro
cmucl
Commits
5296088e
Commit
5296088e
authored
33 years ago
by
wlott
Browse files
Options
Downloads
Patches
Plain Diff
Moved *type-predicate* and *predicate-type* into the backend structure.
parent
c39cf67c
No related branches found
No related tags found
No related merge requests found
Changes
3
Hide whitespace changes
Inline
Side-by-side
Showing
3 changed files
compiler/checkgen.lisp
+4
-3
4 additions, 3 deletions
compiler/checkgen.lisp
compiler/constraint.lisp
+2
-2
2 additions, 2 deletions
compiler/constraint.lisp
compiler/typetran.lisp
+46
-45
46 additions, 45 deletions
compiler/typetran.lisp
with
52 additions
and
50 deletions
compiler/checkgen.lisp
+
4
−
3
View file @
5296088e
...
@@ -7,7 +7,7 @@
...
@@ -7,7 +7,7 @@
;;; Scott Fahlman or slisp-group@cs.cmu.edu.
;;; Scott Fahlman or slisp-group@cs.cmu.edu.
;;;
;;;
(
ext:file-comment
(
ext:file-comment
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/checkgen.lisp,v 1.1
8
199
1
/03/
18 20:54:43 ram
Exp $"
)
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/checkgen.lisp,v 1.1
9
199
2
/03/
21 19:41:14 wlott
Exp $"
)
;;;
;;;
;;; **********************************************************************
;;; **********************************************************************
;;;
;;;
...
@@ -61,7 +61,8 @@
...
@@ -61,7 +61,8 @@
(
or
(
let
((
check
(
type-check-template
type
)))
(
or
(
let
((
check
(
type-check-template
type
)))
(
if
check
(
if
check
(
template-cost
check
)
(
template-cost
check
)
(
let
((
found
(
cdr
(
assoc
type
*type-predicates*
:test
#'
type=
))))
(
let
((
found
(
cdr
(
assoc
type
(
backend-type-predicates
*backend*
)
:test
#'
type=
))))
(
if
found
(
if
found
(
+
(
function-cost
found
)
(
function-cost
'eq
))
(
+
(
function-cost
found
)
(
function-cost
'eq
))
nil
))))
nil
))))
...
@@ -108,7 +109,7 @@
...
@@ -108,7 +109,7 @@
(
let
((
min-cost
(
type-test-cost
type
))
(
let
((
min-cost
(
type-test-cost
type
))
(
min-type
type
)
(
min-type
type
)
(
found-super
nil
))
(
found-super
nil
))
(
dolist
(
x
*
type-predicates
*
)
(
dolist
(
x
(
backend-
type-predicates
*backend*
)
)
(
let
((
stype
(
car
x
)))
(
let
((
stype
(
car
x
)))
(
when
(
and
(
csubtypep
type
stype
)
(
when
(
and
(
csubtypep
type
stype
)
(
not
(
union-type-p
stype
)))
;Not #!% COMMON type.
(
not
(
union-type-p
stype
)))
;Not #!% COMMON type.
...
...
This diff is collapsed.
Click to expand it.
compiler/constraint.lisp
+
2
−
2
View file @
5296088e
...
@@ -7,7 +7,7 @@
...
@@ -7,7 +7,7 @@
;;; Scott Fahlman or slisp-group@cs.cmu.edu.
;;; Scott Fahlman or slisp-group@cs.cmu.edu.
;;;
;;;
(
ext:file-comment
(
ext:file-comment
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/constraint.lisp,v 1.1
1
199
1/12/08 17:24:51 ram
Exp $"
)
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/constraint.lisp,v 1.1
2
199
2/03/21 19:41:31 wlott
Exp $"
)
;;;
;;;
;;; **********************************************************************
;;; **********************************************************************
;;;
;;;
...
@@ -197,7 +197,7 @@
...
@@ -197,7 +197,7 @@
var2
(
continuation-type
arg1
)
var2
(
continuation-type
arg1
)
nil
))))
nil
))))
(
t
(
t
(
let
((
ptype
(
gethash
name
*
predicate-types
*
)))
(
let
((
ptype
(
gethash
name
(
backend-
predicate-types
*backend*
)
)))
(
when
ptype
(
when
ptype
(
add-complement-constraints
if
'typep
(
add-complement-constraints
if
'typep
(
ok-cont-lambda-var
(
first
args
))
(
ok-cont-lambda-var
(
first
args
))
...
...
This diff is collapsed.
Click to expand it.
compiler/typetran.lisp
+
46
−
45
View file @
5296088e
...
@@ -7,7 +7,7 @@
...
@@ -7,7 +7,7 @@
;;; Scott Fahlman or slisp-group@cs.cmu.edu.
;;; Scott Fahlman or slisp-group@cs.cmu.edu.
;;;
;;;
(
ext:file-comment
(
ext:file-comment
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/typetran.lisp,v 1.1
2
199
1/10/24 21:05:00 ram
Exp $"
)
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/typetran.lisp,v 1.1
3
199
2/03/21 19:41:34 wlott
Exp $"
)
;;;
;;;
;;; **********************************************************************
;;; **********************************************************************
;;;
;;;
...
@@ -34,18 +34,11 @@
...
@@ -34,18 +34,11 @@
;;; corresponding predicates) are not maintained in this association. In this
;;; corresponding predicates) are not maintained in this association. In this
;;; case, there need not be any predicate function unless it is required by
;;; case, there need not be any predicate function unless it is required by
;;; Common Lisp.
;;; Common Lisp.
;;; These two variables maintain the translation between types and predicates.
;;; *Predicate-Types* is a hashtable that translates from type predicate names
;;; to CType objects. *Type-Predicates* is an alist (<type> . <predicate>)
;;; that translates from types to predicates. We can't use a hashtable, since
;;; there is no such thing as a Type= hashtable. Establishing this translation
;;;
;;;
(
defvar
*predicate-types*
(
make-hash-table
:test
#'
eq
))
;;; The mappings between predicates and type structures is stored in the
(
proclaim
'
(
hash-table
*predicate-types*
))
;;; backend structure, so that different backends can support different sets
(
defvar
*type-predicates*
())
;;; of predicates.
(
proclaim
'
(
list
*type-predicates*
))
;;;
;;; Define-Type-Predicate -- Interface
;;; Define-Type-Predicate -- Interface
;;;
;;;
...
@@ -54,14 +47,17 @@
...
@@ -54,14 +47,17 @@
Establish an association between the type predicate Name and the
Establish an association between the type predicate Name and the
corresponding Type. This causes the type predicate to be recognized for
corresponding Type. This causes the type predicate to be recognized for
purposes of optimization."
purposes of optimization."
`
(
progn
`
(
%define-type-predicate
',name
',type
))
(
setf
(
gethash
',name
*predicate-types*
)
(
specifier-type
',type
))
;;;
(
setq
*type-predicates*
(
defun
%define-type-predicate
(
name
specifier
)
(
cons
(
cons
(
specifier-type
',type
)
',name
)
(
let
((
type
(
specifier-type
specifier
)))
(
remove
',name
*type-predicates*
:key
#'
cdr
)))
(
setf
(
gethash
name
(
backend-predicate-types
*target-backend*
))
type
)
(
%deftransform
',name
'
(
function
(
t
)
*
)
#'
fold-type-predicate
)
(
setf
(
backend-type-predicates
*target-backend*
)
',name
))
(
cons
(
cons
type
name
)
(
remove
name
(
backend-type-predicates
*target-backend*
)
:key
#'
cdr
)))
(
%deftransform
name
'
(
function
(
t
)
*
)
#'
fold-type-predicate
)
name
))
;;;; IR1 transforms:
;;;; IR1 transforms:
...
@@ -114,35 +110,39 @@
...
@@ -114,35 +110,39 @@
(
ref-leaf
(
ref-leaf
(
continuation-use
(
continuation-use
(
basic-combination-fun
node
))))
(
basic-combination-fun
node
))))
*
predicate-types
*
)))
(
backend-
predicate-types
*backend*
)
)))
(
assert
ctype
)
(
assert
ctype
)
(
ir1-transform-type-predicate
object
ctype
)))
(
ir1-transform-type-predicate
object
ctype
)))
;;;; Standard type predicates:
;;;; Standard type predicates:
(
define-type-predicate
arrayp
array
)
(
defun
define-standard-type-predicates
()
; No atom. Use (not cons) deftype.
(
define-type-predicate
arrayp
array
)
(
define-type-predicate
bit-vector-p
bit-vector
)
; No atom. Use (not cons) deftype.
(
define-type-predicate
characterp
character
)
(
define-type-predicate
bit-vector-p
bit-vector
)
(
define-type-predicate
compiled-function-p
compiled-function
)
(
define-type-predicate
characterp
character
)
(
define-type-predicate
complexp
complex
)
(
define-type-predicate
compiled-function-p
compiled-function
)
(
define-type-predicate
consp
cons
)
(
define-type-predicate
complexp
complex
)
(
define-type-predicate
floatp
float
)
(
define-type-predicate
consp
cons
)
(
define-type-predicate
functionp
function
)
(
define-type-predicate
floatp
float
)
(
define-type-predicate
integerp
integer
)
(
define-type-predicate
functionp
function
)
(
define-type-predicate
keywordp
keyword
)
(
define-type-predicate
integerp
integer
)
(
define-type-predicate
listp
list
)
(
define-type-predicate
keywordp
keyword
)
(
define-type-predicate
null
null
)
(
define-type-predicate
listp
list
)
(
define-type-predicate
numberp
number
)
(
define-type-predicate
null
null
)
(
define-type-predicate
rationalp
rational
)
(
define-type-predicate
numberp
number
)
(
define-type-predicate
simple-bit-vector-p
simple-bit-vector
)
(
define-type-predicate
rationalp
rational
)
(
define-type-predicate
simple-string-p
simple-string
)
(
define-type-predicate
simple-bit-vector-p
simple-bit-vector
)
(
define-type-predicate
simple-vector-p
simple-vector
)
(
define-type-predicate
simple-string-p
simple-string
)
(
define-type-predicate
stringp
string
)
(
define-type-predicate
simple-vector-p
simple-vector
)
(
define-type-predicate
structurep
structure
)
(
define-type-predicate
stringp
string
)
(
define-type-predicate
symbolp
symbol
)
(
define-type-predicate
structurep
structure
)
(
define-type-predicate
vectorp
vector
)
(
define-type-predicate
symbolp
symbol
)
(
define-type-predicate
vectorp
vector
))
(
define-standard-type-predicates
)
;;;; Transforms for type predicates not implemented primitively:
;;;; Transforms for type predicates not implemented primitively:
...
@@ -284,7 +284,7 @@
...
@@ -284,7 +284,7 @@
(
declare
(
type
ctype
type
))
(
declare
(
type
ctype
type
))
(
let
((
res
nil
)
(
let
((
res
nil
)
(
res-type
nil
))
(
res-type
nil
))
(
dolist
(
x
*
type-predicates
*
)
(
dolist
(
x
(
backend-
type-predicates
*backend*
)
)
(
let
((
stype
(
car
x
)))
(
let
((
stype
(
car
x
)))
(
when
(
and
(
csubtypep
type
stype
)
(
when
(
and
(
csubtypep
type
stype
)
(
or
(
not
res-type
)
(
or
(
not
res-type
)
...
@@ -392,7 +392,8 @@
...
@@ -392,7 +392,8 @@
(
def-source-transform
typep
(
object
spec
)
(
def-source-transform
typep
(
object
spec
)
(
if
(
and
(
consp
spec
)
(
eq
(
car
spec
)
'quote
))
(
if
(
and
(
consp
spec
)
(
eq
(
car
spec
)
'quote
))
(
let*
((
type
(
specifier-type
(
cadr
spec
)))
(
let*
((
type
(
specifier-type
(
cadr
spec
)))
(
pred
(
cdr
(
assoc
type
*type-predicates*
:test
#'
type=
))))
(
pred
(
cdr
(
assoc
type
(
backend-type-predicates
*backend*
)
:test
#'
type=
))))
(
if
pred
(
if
pred
`
(
,
pred
,
object
)
`
(
,
pred
,
object
)
(
typecase
type
(
typecase
type
...
...
This diff is collapsed.
Click to expand it.
Preview
0%
Loading
Try again
or
attach a new file
.
Cancel
You are about to add
0
people
to the discussion. Proceed with caution.
Finish editing this message first!
Save comment
Cancel
Please
register
or
sign in
to comment