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
f35516f3
Commit
f35516f3
authored
21 years ago
by
gerd
Browse files
Options
Downloads
Patches
Plain Diff
Boot file for new condition slot documentation.
parent
2290a3ca
No related branches found
No related tags found
No related merge requests found
Changes
1
Hide whitespace changes
Inline
Side-by-side
Showing
1 changed file
bootfiles/18e/boot7.lisp
+159
-0
159 additions, 0 deletions
bootfiles/18e/boot7.lisp
with
159 additions
and
0 deletions
bootfiles/18e/boot7.lisp
0 → 100644
+
159
−
0
View file @
f35516f3
;;;
;;; Bootfile for adding a documentation slot to CONDITION-SLOT.
;;; Use this file as bootstrap.lisp using Pierre Mai's build scripts,
;;;
(
in-package
:conditions
)
;;;
;;; Like DEFSTRUCT, but silently clobber old definitions.
;;;
(
defmacro
defstruct!
(
name
&rest
stuff
)
`
(
handler-bind
((
error
(
lambda
(
c
)
(
declare
(
ignore
c
))
(
invoke-restart
'kernel::clobber-it
))))
(
defstruct
,
name
,@
stuff
)))
;;;
;;; Add the documentation slot.
;;;
(
defstruct!
condition-slot
(
name
(
required-argument
)
:type
symbol
)
(
initargs
(
required-argument
)
:type
list
)
(
readers
(
required-argument
)
:type
list
)
(
writers
(
required-argument
)
:type
list
)
(
initform-p
(
required-argument
)
:type
(
member
t
nil
))
(
initform
(
required-argument
)
:type
t
)
(
allocation
nil
:type
(
member
:instance
:class
nil
))
(
cell
nil
:type
(
or
cons
null
))
(
documentation
nil
:type
(
or
null
string
)))
;;;
;;; Parse the :DOCUMENTATION slot option.
;;;
(
defmacro
define-condition
(
name
(
&rest
parent-types
)
(
&rest
slot-specs
)
&body
options
)
(
let*
((
parent-types
(
or
parent-types
'
(
condition
)))
(
layout
(
find-condition-layout
name
parent-types
))
(
documentation
nil
)
(
report
nil
)
(
slot-name/accessors
())
(
default-initargs
()))
(
collect
((
slots
)
(
all-readers
nil
append
)
(
all-writers
nil
append
))
(
dolist
(
spec
slot-specs
)
(
when
(
keywordp
spec
)
(
warn
"Keyword slot name indicates probable syntax error:~% ~S"
spec
))
(
let*
((
spec
(
if
(
consp
spec
)
spec
(
list
spec
)))
(
slot-name
(
first
spec
))
(
allocation
:instance
)
(
documentation
nil
)
(
initform-p
nil
)
initform
)
(
collect
((
initargs
)
(
readers
)
(
writers
))
(
do
((
options
(
rest
spec
)
(
cddr
options
)))
((
null
options
))
(
unless
(
and
(
consp
options
)
(
consp
(
cdr
options
)))
(
simple-program-error
"Malformed condition slot spec:~% ~S."
spec
))
(
let
((
arg
(
second
options
)))
(
case
(
first
options
)
(
:reader
(
readers
arg
))
(
:writer
(
writers
arg
))
(
:accessor
(
readers
arg
)
(
writers
`
(
setf
,
arg
)))
(
:initform
(
when
initform-p
(
simple-program-error
"More than one :INITFORM in:~% ~S"
spec
))
(
setq
initform-p
t
)
(
setq
initform
arg
))
(
:initarg
(
initargs
arg
))
(
:allocation
(
setq
allocation
arg
))
(
:documentation
(
when
documentation
(
simple-program-error
"More than one slot :DOCUMENTATION in~% ~s"
spec
))
(
unless
(
stringp
arg
)
(
simple-program-error
"Slot :DOCUMENTATION is not a string in~% ~s"
spec
))
(
setq
documentation
arg
))
(
:type
)
(
t
(
simple-program-error
"Unknown slot option:~% ~S"
(
first
options
))))))
(
push
(
list
slot-name
(
readers
)
(
writers
))
slot-name/accessors
)
(
all-readers
(
readers
))
(
all-writers
(
writers
))
(
slots
`
(
make-condition-slot
:name
',slot-name
:initargs
',
(
initargs
)
:readers
',
(
readers
)
:writers
',
(
writers
)
:initform-p
',initform-p
:documentation
',documentation
:initform
,
(
if
(
constantp
initform
)
`
',
(
eval
initform
)
`
#'
(
lambda
()
,
initform
)))))))
(
dolist
(
option
options
)
(
unless
(
consp
option
)
(
simple-program-error
"Bad option:~% ~S"
option
))
(
case
(
first
option
)
(
:documentation
(
setq
documentation
(
second
option
)))
(
:report
(
let
((
arg
(
second
option
)))
(
setq
report
(
if
(
stringp
arg
)
`
#'
(
lambda
(
condition
stream
)
(
declare
(
ignore
condition
))
(
write-string
,
arg
stream
))
`
#'
(
lambda
(
condition
stream
)
(
funcall
#'
,
arg
condition
stream
))))))
(
:default-initargs
(
do
((
initargs
(
rest
option
)
(
cddr
initargs
)))
((
endp
initargs
))
(
let
((
val
(
second
initargs
)))
(
setq
default-initargs
(
list*
`
',
(
first
initargs
)
(
if
(
constantp
val
)
`
',
(
eval
val
)
`
#'
(
lambda
()
,
val
))
default-initargs
)))))
(
t
(
simple-program-error
"Unknown option: ~S"
(
first
option
)))))
`
(
progn
(
eval-when
(
compile
load
eval
)
(
%compiler-define-condition
',name
',parent-types
',layout
))
(
declaim
(
ftype
(
function
(
t
)
t
)
,@
(
all-readers
)))
(
declaim
(
ftype
(
function
(
t
t
)
t
)
,@
(
all-writers
)))
,@
(
when
*make-condition-accessor-methods*
(
collect
((
methods
))
(
dolist
(
elt
slot-name/accessors
)
(
destructuring-bind
(
slot-name
readers
writers
)
elt
(
dolist
(
reader
readers
)
(
methods
(
make-condition-accessor
reader
name
slot-name
'reader
t
)))
(
dolist
(
writer
writers
)
(
methods
(
make-condition-accessor
writer
name
slot-name
'writer
t
)))))
(
methods
)))
(
%define-condition
',name
(
list
,@
(
slots
))
,
documentation
,
report
(
list
,@
default-initargs
))))))
;;; end of file
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