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
cc2cdf06
Commit
cc2cdf06
authored
34 years ago
by
wlott
Browse files
Options
Downloads
Patches
Plain Diff
Initial CMU version.
parent
bce4c047
No related branches found
No related tags found
No related merge requests found
Changes
5
Hide whitespace changes
Inline
Side-by-side
Showing
5 changed files
pcl/cmu-low.lisp
+44
-22
44 additions, 22 deletions
pcl/cmu-low.lisp
pcl/defsys.lisp
+4
-7
4 additions, 7 deletions
pcl/defsys.lisp
pcl/fin.lisp
+50
-29
50 additions, 29 deletions
pcl/fin.lisp
pcl/pkg.lisp
+5
-1
5 additions, 1 deletion
pcl/pkg.lisp
pcl/walk.lisp
+57
-4
57 additions, 4 deletions
pcl/walk.lisp
with
160 additions
and
63 deletions
pcl/cmu-low.lisp
+
44
−
22
View file @
cc2cdf06
;;;-*-Mode:LISP; Package:
(
PCL
LISP 1000)
; Base:10; Syntax:Common-lisp -*-
;;;-*-Mode:LISP; Package:PCL; Base:10; Syntax:Common-lisp -*-
;;;
;;;
;;; *************************************************************************
;;; *************************************************************************
;;; Copyright (c) 1985, 1986, 1987, 1988
, 1989, 1990
Xerox Corporation.
;;; Copyright (c) 1985, 1986, 1987, 1988 Xerox Corporation.
;;; All rights reserved.
;;; All rights reserved.
;;;
;;;
;;; Use and copying of this software and preparation of derivative works
;;; Use and copying of this software and preparation of derivative works
...
@@ -33,27 +33,49 @@
...
@@ -33,27 +33,49 @@
;;;;;; Cache No's
;;;;;; Cache No's
;;
;;
;;; Abuse the type declaration, but it generates great code.
(
proclaim
'
(
inline
object-cache-no
))
;(defun symbol-cache-no (symbol mask)
; (logand (the fixnum (system:%primitive lisp::make-immediate-type
; symbol
; system::%+-fixnum-type))
; (the fixnum mask)))
;
;(clc::deftransform symbol-cache-no symbol-cache-no-transform (symbol mask)
; `(logand (the fixnum (system:%primitive lisp::make-immediate-type
; ,symbol
; system::%+-fixnum-type))
; (the fixnum ,mask)))
(
defun
object-cache-no
(
symbol
mask
)
(
defun
object-cache-no
(
symbol
mask
)
(
logand
(
the
fixnum
(
system:%primitive
lisp::make-immediate-type
(
logand
(
ext:truly-the
fixnum
(
system:%primitive
make-fixnum
symbol
))
symbol
system::%+-fixnum-type
))
(
the
fixnum
mask
)))
(
the
fixnum
mask
)))
(
clc::deftransform
object-cache-no
object-cache-no-transform
(
symbol
mask
)
`
(
logand
(
the
fixnum
(
system:%primitive
lisp::make-immediate-type
,
symbol
(
defun
function-arglist
(
fcn
)
system::%+-fixnum-type
))
"Returns the argument list of a compiled function, if possible."
(
cond
((
symbolp
fcn
)
(
when
(
fboundp
fcn
)
(
function-arglist
(
symbol-function
fcn
))))
((
eval:interpreted-function-p
fcn
)
(
eval:interpreted-function-name
fcn
))
((
functionp
fcn
)
(
let
((
lambda-expr
(
function-lambda-expression
fcn
)))
(
if
lambda-expr
(
cadr
lambda-expr
)
(
let
((
function
(
kernel:%closure-function
fcn
)))
(
values
(
read-from-string
(
kernel:%function-header-arglist
function
)))))))))
;;; We have this here and in fin.lisp, 'cause PCL wants to compile this
;;; file first.
;;;
(
defsetf
funcallable-instance-name
set-funcallable-instance-name
)
(
defun
set-function-name
(
fcn
new-name
)
"Set the name of a compiled function object."
(
cond
((
symbolp
fcn
)
(
set-function-name
(
symbol-function
fcn
)
new-name
))
((
funcallable-instance-p
fcn
)
(
setf
(
funcallable-instance-name
fcn
)
new-name
)
fcn
)
(
t
(
let
((
header
(
kernel:%closure-function
fcn
)))
(
system:%primitive
c::set-function-name
header
(
if
(
symbolp
new-name
)
new-name
(
let
((
*package*
*the-pcl-package*
)
(
*print-case*
:upcase
)
(
*print-gensym*
't
))
(
prin1-to-string
new-name
)))))
fcn
)))
This diff is collapsed.
Click to expand it.
pcl/defsys.lisp
+
4
−
7
View file @
cc2cdf06
...
@@ -269,7 +269,7 @@ and load your system with:
...
@@ -269,7 +269,7 @@ and load your system with:
#+
(
and
Lucid
MIPS
)
(
"lisp"
.
"mbin"
)
#+
(
and
Lucid
MIPS
)
(
"lisp"
.
"mbin"
)
#+
(
and
Lucid
PRISM
)
(
"lisp"
.
"abin"
)
#+
(
and
Lucid
PRISM
)
(
"lisp"
.
"abin"
)
#+
excl
(
"cl"
.
"fasl"
)
#+
excl
(
"cl"
.
"fasl"
)
#+
:CMU
(
"
s
lisp"
.
"
s
fasl"
)
#+
:CMU
(
"lisp"
.
#+
pmax
"mips-fasl"
#-
(
or
pmax
)
"fasl"
)
#+
HP
(
"l"
.
"b"
)
#+
HP
(
"l"
.
"b"
)
#+
TI
(
"lisp"
.
#.
(
string
(
si::local-binary-file-type
)))
#+
TI
(
"lisp"
.
#.
(
string
(
si::local-binary-file-type
)))
#+
:gclisp
(
"LSP"
.
"F2S"
)
#+
:gclisp
(
"LSP"
.
"F2S"
)
...
@@ -395,7 +395,8 @@ and load your system with:
...
@@ -395,7 +395,8 @@ and load your system with:
(
let
((
*system-directory*
(
funcall
(
car
system
)))
(
let
((
*system-directory*
(
funcall
(
car
system
)))
(
modules
(
cadr
system
))
(
modules
(
cadr
system
))
(
transformations
()))
(
transformations
()))
(
labels
((
load-source
(
name
pathname
)
(
labels
(
#+
nil
;; This isn't used?
(
load-source
(
name
pathname
)
(
format
t
"~&Loading source of ~A..."
name
)
(
format
t
"~&Loading source of ~A..."
name
)
(
or
print-only
(
load
pathname
)))
(
or
print-only
(
load
pathname
)))
(
load-binary
(
name
pathname
)
(
load-binary
(
name
pathname
)
...
@@ -557,11 +558,7 @@ and load your system with:
...
@@ -557,11 +558,7 @@ and load your system with:
;;
;;
#+
LUCID
(
or
lucid::*source-pathname*
(
bad-time
))))
#+
LUCID
(
or
lucid::*source-pathname*
(
bad-time
))))
(
defvar
*pcl-directory*
(
defvar
*pcl-directory*
(
pathname
"pcl:"
))
(
or
(
load-truename
t
)
(
error
"Because load-truename is not implemented in this port~%~
of PCL, you must manually edit the definition of the~%~
variable *pcl-directory* in the file defsys.lisp."
)))
(
defsystem
pcl
(
defsystem
pcl
...
...
This diff is collapsed.
Click to expand it.
pcl/fin.lisp
+
50
−
29
View file @
cc2cdf06
...
@@ -106,12 +106,16 @@ explicitly marked saying who wrote it.
...
@@ -106,12 +106,16 @@ explicitly marked saying who wrote it.
;;; This must be SETF'able.
;;; This must be SETF'able.
;;;
;;;
(
eval-when
(
compile
eval
load
)
(
defconstant
funcallable-instance-data
(
defconstant
funcallable-instance-data
'
(
wrapper
slots
)
'
(
wrapper
slots
)
"These are the 'data-slots' which funcallable instances have so that
"These are the 'data-slots' which funcallable instances have so that
the meta-class funcallable-standard-class can store class, and static
the meta-class funcallable-standard-class can store class, and static
slots in them."
)
slots in them."
)
)
; eval-when (compile eval load)
(
defmacro
funcallable-instance-data-position
(
data
)
(
defmacro
funcallable-instance-data-position
(
data
)
(
if
(
and
(
consp
data
)
(
if
(
and
(
consp
data
)
(
eq
(
car
data
)
'quote
)
(
eq
(
car
data
)
'quote
)
...
@@ -965,44 +969,61 @@ explicitly marked saying who wrote it.
...
@@ -965,44 +969,61 @@ explicitly marked saying who wrote it.
;;; Implementation of funcallable instances for CMU Common Lisp.
;;; Implementation of funcallable instances for CMU Common Lisp.
;;;
;;;
;;; Similiar to the code for VAXLISP implementation.
#+
:CMU
#+
:CMU
(
progn
(
progn
(
defstruct
funcallable-instance-info
(
function
#'
(
lambda
(
&rest
args
)
(
declare
(
ignore
args
))
(
called-fin-without-function
))
:type
function
)
(
name
"Unnamed funcallable instance"
)
.
#.
funcallable-instance-data
)
(
proclaim
'
(
inline
funcallable-instance-info
funcallable-instance-p
))
(
defun
funcallable-instance-info
(
fin
)
(
system:find-if-in-closure
#'
funcallable-instance-info-p
fin
))
(
defun
allocate-funcallable-instance-1
()
(
defun
allocate-funcallable-instance-1
()
`
(
lisp::%compiled-closure%
(
let
((
info
(
make-funcallable-instance-info
)))
()
#'
(
lambda
(
&rest
args
)
,
#'
(
lambda
(
&rest
args
)
(
apply
(
funcallable-instance-info-function
info
)
args
))))
(
declare
(
ignore
args
))
(
called-fin-without-function
))
,
(
make-array
(
length
funcallable-instance-data
))))
(
proclaim
'
(
inline
funcallable-instance-p
))
(
defun
funcallable-instance-p
(
x
)
(
and
(
consp
x
)
(
eq
(
car
x
)
'lisp::%compiled-closure%
)
(
not
(
null
(
cdddr
x
)))))
(
defun
set-funcallable-instance-function
(
fin
func
)
(
defun
funcallable-instance-p
(
thing
)
(
cond
((
not
(
funcallable-instance-p
fin
))
(
and
(
functionp
thing
)
(
error
"~S is not a funcallable-instance"
fin
))
(
=
(
kernel:get-type
thing
)
vm:closure-header-type
)
((
not
(
functionp
func
))
(
funcallable-instance-info
thing
)
(
error
"~S is not a function"
func
))
t
))
((
and
(
consp
func
)
(
eq
(
car
func
)
'lisp::%compiled-closure%
))
(
setf
(
cadr
fin
)
(
cadr
func
)
(
caddr
fin
)
(
caddr
func
)))
(
t
(
set-funcallable-instance-function
fin
(
make-trampoline
func
)))))
(
defun
make-trampoline
(
function
)
#'
(
lambda
(
&rest
args
)
(
apply
function
args
)))
(
eval-when
(
eval
)
(
compile
'make-trampoline
))
(
defun
set-funcallable-instance-function
(
fin
new-value
)
(
setf
(
funcallable-instance-info-function
(
funcallable-instance-info
fin
))
new-value
))
(
defun
funcallable-instance-name
(
fin
)
(
funcallable-instance-info-name
(
funcallable-instance-info
fin
)))
(
defun
set-funcallable-instance-name
(
fin
new-value
)
(
setf
(
funcallable-instance-info-name
(
funcallable-instance-info
fin
))
new-value
))
(
defsetf
funcallable-instance-name
set-funcallable-instance-name
)
(
defmacro
funcallable-instance-data-1
(
fin
slot
)
(
unless
(
and
(
listp
slot
)
(
eq
(
car
slot
)
'quote
))
(
error
"Non-constant name for funcallable-instance-data-1: ~S"
slot
))
`
(
,
(
intern
(
concatenate
'simple-string
"FUNCALLABLE-INSTANCE-INFO-"
(
string
(
cadr
slot
)))
*the-pcl-package*
)
(
funcallable-instance-info
,
fin
)))
(
defmacro
funcallable-instance-data-1
(
instance
data
)
`
(
svref
(
cadddr
,
instance
)
(
funcallable-instance-data-position
,
data
)))
)
; End of :CMU
)
; End of :CMU
...
...
This diff is collapsed.
Click to expand it.
pcl/pkg.lisp
+
5
−
1
View file @
cc2cdf06
...
@@ -40,6 +40,10 @@
...
@@ -40,6 +40,10 @@
defmethod
)
defmethod
)
*the-pcl-package*
)
*the-pcl-package*
)
#+
CMU
(
shadow
'
(
destructuring-bind
)
*the-pcl-package*
)
#+
GCLisp
#+
GCLisp
(
shadow
'
(
string-append
memq
assq
delq
neq
make-instance
)
(
shadow
'
(
string-append
memq
assq
delq
neq
make-instance
)
*the-pcl-package*
)
*the-pcl-package*
)
...
@@ -117,7 +121,7 @@
...
@@ -117,7 +121,7 @@
)
;eval-when
)
;eval-when
#-
(
or
KCL
IBCL
)
#-
(
or
KCL
IBCL
)
(
export
*exports*
*the-pcl-package*
)
(
export
'#.
*exports*
*the-pcl-package*
)
#+
(
or
KCL
IBCL
)
#+
(
or
KCL
IBCL
)
(
mapc
'export
(
list
*exports*
)
(
list
*the-pcl-package*
))
(
mapc
'export
(
list
*exports*
)
(
list
*the-pcl-package*
))
...
...
This diff is collapsed.
Click to expand it.
pcl/walk.lisp
+
57
−
4
View file @
cc2cdf06
...
@@ -805,6 +805,57 @@
...
@@ -805,6 +805,57 @@
)
;#+gclisp
)
;#+gclisp
;;;; CMU Common Lisp version of environment frobbing stuff.
;;; In CMU Common Lisp, the environment (well, the function/macro part of
;;; the environment) is represented as a list of entries, with each entry
;;; being of the form (name type . fn) where type is either macro or
;;; function.
#+
:CMU
(
progn
(
defmacro
with-augmented-environment
((
new-env
old-env
&key
functions
macros
)
&body
body
)
`
(
let
((
,
new-env
(
with-augmented-environment-internal
,
old-env
,
functions
,
macros
)))
,@
body
))
(
defun
with-augmented-environment-internal
(
env
functions
macros
)
;; Note: In order to record the correct function definition, we would
;; have to create an interpreted closure, but the with-new-definition
;; macro down below makes no distinction between flet and labels, so
;; we have no idea what to use for the environment. So we just blow it
;; off, 'cause anything real we do would be wrong. We still have to
;; make an entry so we can tell functions from macros.
(
let
((
c::*lexical-environment*
(
or
env
(
c::make-null-environment
))))
(
c::make-lexenv
:functions
(
append
(
mapcar
#'
(
lambda
(
f
)
(
list
(
car
f
)
'function
))
functions
)
(
mapcar
#'
(
lambda
(
m
)
(
list*
(
car
m
)
'lisp::macro
(
cadr
m
)))
macros
)))))
(
defun
environment-function
(
env
fn
)
(
when
env
(
let
((
entry
(
assoc
fn
(
c::lexenv-functions
env
)
:test
#'
eq
)))
(
and
entry
(
eq
(
cadr
entry
)
'function
)
(
cddr
entry
)))))
(
defun
environment-macro
(
env
macro
)
(
when
env
(
let
((
entry
(
assoc
macro
(
c::lexenv-functions
env
)
:test
#'
eq
)))
(
and
entry
(
eq
(
cadr
entry
)
'lisp::macro
)
(
cddr
entry
)))))
)
; end of #+:CMU
(
defmacro
with-new-definition-in-environment
(
defmacro
with-new-definition-in-environment
...
@@ -946,9 +997,7 @@
...
@@ -946,9 +997,7 @@
#+
(
and
dec
vax
common
)
(
get
symbol
'system::globally-special
)
#+
(
and
dec
vax
common
)
(
get
symbol
'system::globally-special
)
#+
(
or
KCL
IBCL
)
(
si:specialp
symbol
)
#+
(
or
KCL
IBCL
)
(
si:specialp
symbol
)
#+
excl
(
get
symbol
'excl::.globally-special.
)
#+
excl
(
get
symbol
'excl::.globally-special.
)
#+
:CMU
(
or
(
get
symbol
'lisp::globally-special
)
#+
:CMU
(
eq
(
ext:info
variable
kind
symbol
)
:special
)
(
get
symbol
'clc::globally-special-in-compiler
))
#+
HP-HPLabs
(
member
(
get
symbol
'impl:vartype
)
#+
HP-HPLabs
(
member
(
get
symbol
'impl:vartype
)
'
(
impl:fluid
impl:global
)
'
(
impl:fluid
impl:global
)
:test
#'
eq
)
:test
#'
eq
)
...
@@ -1260,7 +1309,11 @@
...
@@ -1260,7 +1309,11 @@
(
SET
(
SET
(
walk-form-internal
form
:SET
env
))
(
walk-form-internal
form
:SET
env
))
((
LAMBDA
CALL
)
((
LAMBDA
CALL
)
(
cond
((
symbolp
form
)
form
)
(
cond
((
or
(
symbolp
form
)
(
and
(
listp
form
)
(
=
(
length
form
)
2
)
(
eq
(
car
form
)
'setf
)))
form
)
#+
Lispm
#+
Lispm
((
sys:validate-function-spec
form
)
form
)
((
sys:validate-function-spec
form
)
form
)
(
t
(
walk-form-internal
form
context
env
)))))
(
t
(
walk-form-internal
form
context
env
)))))
...
...
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