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
cells
cells
Commits
12d98511
Commit
12d98511
authored
Feb 16, 2008
by
Kenny Tilton
Browse files
*** empty log message ***
parent
c2dfec96
Changes
3
Hide whitespace changes
Inline
Side-by-side
cells-test/test.lisp
View file @
12d98511
...
...
@@ -51,7 +51,6 @@ them (ie, does not access them)
#| do list
-- can we lose the special handling of the .kids slot?
-- test drifters (and can they be handled without creating a special
subclass for them?)
...
...
defmodel.lisp
View file @
12d98511
...
...
@@ -24,75 +24,75 @@ See the Lisp Lesser GNU Public License for more details.
(
eval-when
(
:compile-toplevel
:execute
:load-toplevel
)
(
setf
(
get
',class
:cell-types
)
nil
)
(
setf
(
get
',class
'slots-excluded-from-persistence
)
',
(
loop
for
slotspec
in
slotspecs
unless
(
and
(
getf
(
cdr
slotspec
)
:ps
t
)
(
getf
(
cdr
slotspec
)
:persistable
t
))
collect
(
car
slotspec
))))
',
(
loop
for
slotspec
in
slotspecs
unless
(
and
(
getf
(
cdr
slotspec
)
:ps
t
)
(
getf
(
cdr
slotspec
)
:persistable
t
))
collect
(
car
slotspec
))))
;; define slot macros before class so they can appear in
;; initforms and default-initargs
,@
(
delete
nil
(
loop
for
slotspec
in
slotspecs
nconcing
(
destructuring-bind
(
slotname
&rest
slotargs
&key
(
cell
t
)
owning
(
accessor
slotname
)
reader
&allow-other-keys
)
slotspec
(
loop
for
slotspec
in
slotspecs
nconcing
(
destructuring-bind
(
slotname
&rest
slotargs
&key
(
cell
t
)
owning
(
accessor
slotname
)
reader
&allow-other-keys
)
slotspec
(
declare
(
ignorable
slotargs
owning
))
(
list
(
when
cell
(
let*
((
reader-fn
(
or
reader
accessor
))
(
deriver-fn
(
intern$
"^"
(
symbol-name
reader-fn
))))
`
(
eval-when
(
:compile-toplevel
:execute
:load-toplevel
)
(
unless
(
macro-function
',deriver-fn
)
(
defmacro
,
deriver-fn
()
`
(
,
',reader-fn
self
)))
#+
sbcl
(
unless
(
fboundp
',reader-fn
)
(
defgeneric
,
reader-fn
(
slot
))))))))))
(
declare
(
ignorable
slotargs
owning
))
(
list
(
when
cell
(
let*
((
reader-fn
(
or
reader
accessor
))
(
deriver-fn
(
intern$
"^"
(
symbol-name
reader-fn
))))
`
(
eval-when
(
:compile-toplevel
:execute
:load-toplevel
)
(
unless
(
macro-function
',deriver-fn
)
(
defmacro
,
deriver-fn
()
`
(
,
',reader-fn
self
)))
#+
sbcl
(
unless
(
fboundp
',reader-fn
)
(
defgeneric
,
reader-fn
(
slot
))))))))))
;
; ------- defclass --------------- (^slot-value ,model ',',slotname)
;
;
; ------- defclass --------------- (^slot-value ,model ',',slotname)
;
(
progn
(
defclass
,
class
,
(
or
directsupers
'
(
model-object
))
;; now we can def the class
,
(
mapcar
(
lambda
(
s
)
(
list*
(
car
s
)
(
let
((
ias
(
cdr
s
)))
(
remf
ias
:persistable
)
(
remf
ias
:ps
)
;; We handle accessor below
(
when
(
getf
ias
:cell
t
)
(
remf
ias
:reader
)
(
remf
ias
:writer
)
(
remf
ias
:accessor
))
(
remf
ias
:cell
)
(
remf
ias
:owning
)
(
remf
ias
:unchanged-if
)
ias
)))
(
mapcar
#'
copy-list
slotspecs
))
(
:documentation
,@
(
or
(
cdr
(
find
:documentation
options
:key
#'
car
))
'
(
"chya"
)))
(
:default-initargs
;; nil ok and needed: acl oddity in re not clearing d-i's sans this
,@
(
cdr
(
find
:default-initargs
options
:key
#'
car
)))
(
:metaclass
,
(
or
(
cadr
(
find
:metaclass
options
:key
#'
car
))
'standard-class
)))
,
(
mapcar
(
lambda
(
s
)
(
list*
(
car
s
)
(
let
((
ias
(
cdr
s
)))
(
remf
ias
:persistable
)
(
remf
ias
:ps
)
;; We handle accessor below
(
when
(
getf
ias
:cell
t
)
(
remf
ias
:reader
)
(
remf
ias
:writer
)
(
remf
ias
:accessor
))
(
remf
ias
:cell
)
(
remf
ias
:owning
)
(
remf
ias
:unchanged-if
)
ias
)))
(
mapcar
#'
copy-list
slotspecs
))
(
:documentation
,@
(
or
(
cdr
(
find
:documentation
options
:key
#'
car
))
'
(
"chya"
)))
(
:default-initargs
;; nil ok and needed: acl oddity in re not clearing d-i's sans this
,@
(
cdr
(
find
:default-initargs
options
:key
#'
car
)))
(
:metaclass
,
(
or
(
cadr
(
find
:metaclass
options
:key
#'
car
))
'standard-class
)))
(
defmethod
shared-initialize
:after
((
self
,
class
)
slot-names
&rest
iargs
&key
)
(
declare
(
ignore
slot-names
iargs
))
,
(
when
(
and
directsupers
(
not
(
member
'model-object
directsupers
)))
`
(
unless
(
typep
self
'model-object
)
(
error
"If no superclass of ~a inherits directly
`
(
unless
(
typep
self
'model-object
)
(
error
"If no superclass of ~a inherits directly
or indirectly from model-object, model-object must be included as a direct super-class in
the defmodel form for ~a"
',class
',class
))))
;
; slot accessors once class is defined...
;
;
; slot accessors once class is defined...
;
,@
(
mapcar
(
lambda
(
slotspec
)
(
destructuring-bind
(
slotname
&rest
slotargs
&key
(
cell
t
)
owning
unchanged-if
(
accessor
slotname
)
reader
writer
type
&allow-other-keys
)
(
slotname
&rest
slotargs
&key
(
cell
t
)
owning
unchanged-if
(
accessor
slotname
)
reader
writer
type
&allow-other-keys
)
slotspec
(
declare
(
ignorable
slotargs
))
...
...
@@ -100,27 +100,27 @@ the defmodel form for ~a" ',class ',class))))
(
let*
((
reader-fn
(
or
reader
accessor
))
(
writer-fn
(
or
writer
accessor
))
)
`
(
eval-when
(
#+
sbcl
:load-toplevel
:execute
)
; ph -- prevent sbcl warning
`
(
progn
;;
eval-when (#+sbcl :load-toplevel :execute) ; ph -- prevent sbcl warning
(
setf
(
md-slot-cell-type
',class
',slotname
)
,
cell
)
,
(
when
owning
`
(
setf
(
md-slot-owning
',class
',slotname
)
,
owning
))
`
(
setf
(
md-slot-owning
',class
',slotname
)
,
owning
))
,
(
when
reader-fn
`
(
defmethod
,
reader-fn
((
self
,
class
))
(
md-slot-value
self
',slotname
)))
`
(
defmethod
,
reader-fn
((
self
,
class
))
(
md-slot-value
self
',slotname
)))
,
(
when
writer-fn
`
(
defmethod
(
setf
,
writer-fn
)
(
new-value
(
self
,
class
))
(
setf
(
md-slot-value
self
',slotname
)
,
(
if
type
`
(
coerce
new-value
',type
)
'new-value
))))
`
(
defmethod
(
setf
,
writer-fn
)
(
new-value
(
self
,
class
))
(
setf
(
md-slot-value
self
',slotname
)
,
(
if
type
`
(
coerce
new-value
',type
)
'new-value
))))
,
(
when
unchanged-if
`
(
def-c-unchanged-test
(
,
class
,
slotname
)
,
unchanged-if
))
`
(
def-c-unchanged-test
(
,
class
,
slotname
)
,
unchanged-if
))
)
))
))
slotspecs
)
slotspecs
)
(
find-class
',class
))))
(
defun
defmd-canonicalize-slot
(
slotname
...
...
utils-kt/detritus.lisp
View file @
12d98511
...
...
@@ -147,27 +147,48 @@ See the Lisp Lesser GNU Public License for more details.
#+
allegro
(
defun
line-count
(
path
&optional
show-files
(
depth
0
))
(
defun
line-count
(
path
&optional
show-files
(
max-depth
most-positive-fixnum
)
no-semis
(
depth
0
))
(
cond
((
excl:file-directory-p
path
)
(
when
show-files
(
format
t
"~&~v,8t~a counts:"
depth
(
pathname-directory
path
)))
(
let
((
directory-lines
(
loop
for
file
in
(
directory
path
:directories-are-files
nil
)
for
lines
=
(
line-count
file
show-files
(
1+
depth
))
when
(
and
show-files
(
plusp
lines
))
do
(
bwhen
(
fname
(
pathname-name
file
))
(
format
t
"~&~v,8t~a ~,40t~d"
(
1+
depth
)
fname
lines
))
summing
lines
)))
(
unless
(
zerop
directory-lines
)
(
format
t
"~&~v,8t~a ~,50t~d"
depth
(
pathname-directory
path
)
directory-lines
))
directory-lines
))
(
if
(
>=
depth
max-depth
)
(
progn
(
format
t
"~&~v,8t~a dir too deep:"
depth
(
pathname-directory
path
))
0
)
(
progn
(
when
show-files
(
format
t
"~&~v,8t~a counts:"
depth
(
pathname-directory
path
)))
(
let
((
directory-lines
(
loop
for
file
in
(
directory
path
:directories-are-files
nil
)
for
lines
=
(
line-count
file
show-files
max-depth
no-semis
(
1+
depth
))
when
(
and
show-files
(
plusp
lines
))
do
(
bwhen
(
fname
(
pathname-name
file
))
(
format
t
"~&~v,8t~a ~,40t~d"
(
1+
depth
)
fname
lines
))
summing
lines
)))
(
unless
(
zerop
directory-lines
)
(
format
t
"~&~v,8t~a ~,50t~d"
depth
(
pathname-directory
path
)
directory-lines
))
directory-lines
))))
((
find
(
pathname-type
path
)
'
(
"cl"
"lisp"
"c"
"h"
"java"
)
:test
'string-equal
)
(
source-line-count
path
))
(
source-line-count
path
no-semis
))
(
t
0
)))
(
defun
source-line-count
(
path
no-semis
)
(
with-open-file
(
s
path
)
(
loop
with
block-rem
=
0
for
line
=
(
read-line
s
nil
nil
)
for
trim
=
(
when
line
(
string-trim
'
(
#\space
#\tab
)
line
))
while
line
when
(
>
(
length
trim
)
1
)
do
(
cond
((
string=
"#|"
(
subseq
trim
0
2
))(
incf
block-rem
))
((
string=
"|#"
(
subseq
trim
0
2
))(
decf
block-rem
)))
unless
(
or
(
string=
trim
""
)
(
and
no-semis
(
or
(
plusp
block-rem
)
(
char=
#\;
(
schar
trim
0
)))))
count
1
)))
#+
save
(
defun
source-line-count
(
path
)
(
with-open-file
(
s
path
)
(
loop
with
lines
=
0
...
...
@@ -180,7 +201,8 @@ See the Lisp Lesser GNU Public License for more details.
#+
(
or
)
(
line-count
(
make-pathname
:device
"c"
:directory
`
(
:absolute
"0dev"
)))
:directory
`
(
:absolute
"0Algebra"
"Cells"
))
nil
1
t
)
#+
(
or
)
(
loop
for
d1
in
'
(
"cl-s3"
"kpax"
"puri-1.5.1"
"s-base64"
"s-http-client"
"s-http-server"
"s-sysdeps"
"s-utils"
"s-xml"
)
...
...
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