Skip to content
GitLab
Explore
Sign in
Register
Primary navigation
Search or go to…
Project
A
asdf
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
Container Registry
Model registry
Operate
Environments
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
Hugo Ishimaru
asdf
Commits
3d5b72d2
Commit
3d5b72d2
authored
23 years ago
by
Christophe Rhodes
Browse files
Options
Downloads
Patches
Plain Diff
Commit of my sources on general principles
parent
a3240393
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
asdf.lisp
+48
-8
48 additions, 8 deletions
asdf.lisp
with
48 additions
and
8 deletions
asdf.lisp
+
48
−
8
View file @
3d5b72d2
...
@@ -84,6 +84,18 @@
...
@@ -84,6 +84,18 @@
;; because quite often that's not what we actually use it for)
;; because quite often that's not what we actually use it for)
(
pathname
:initarg
:pathname
)))
(
pathname
:initarg
:pathname
)))
(
defmethod
string-unix-common-casify
(
string
&key
(
start
0
)
end
)
(
unless
end
(
setf
end
(
length
string
)))
(
let
((
result
(
copy-seq
string
)))
(
cond
((
every
(
lambda
(
x
)
(
and
(
char>=
x
#\A
)
(
char<=
x
#\Z
)))
(
subseq
string
start
end
))
(
nstring-downcase
result
:start
start
:end
end
))
((
every
(
lambda
(
x
)
(
and
(
char>=
x
#\a
)
(
char<=
x
#\z
)))
(
subseq
string
start
end
))
(
nstring-upcase
result
:start
start
:end
end
))
(
t
result
))))
(
defmethod
component-pathname
((
component
component
))
(
defmethod
component-pathname
((
component
component
))
(
let
((
*default-pathname-defaults*
*component-parent-pathname*
))
(
let
((
*default-pathname-defaults*
*component-parent-pathname*
))
(
if
(
slot-boundp
component
'pathname
)
(
if
(
slot-boundp
component
'pathname
)
...
@@ -91,8 +103,7 @@
...
@@ -91,8 +103,7 @@
(
cond
((
pathnamep
p
)
(
cond
((
pathnamep
p
)
(
merge-pathnames
p
))
(
merge-pathnames
p
))
((
and
(
stringp
p
)
(
>
(
length
p
)
0
))
((
and
(
stringp
p
)
(
>
(
length
p
)
0
))
(
destructuring-bind
(
name
type
)
(
split
p
2
'
(
#\.
))
(
merge-pathnames
p
))
(
merge-pathnames
(
make-pathname
:name
name
:type
type
))))
((
and
(
stringp
p
)
(
=
(
length
p
)
0
))
((
and
(
stringp
p
)
(
=
(
length
p
)
0
))
*component-parent-pathname*
)
*component-parent-pathname*
)
(
t
(
t
...
@@ -136,9 +147,10 @@
...
@@ -136,9 +147,10 @@
(
"java"
.
java-source-file
)))
(
"java"
.
java-source-file
)))
(
defmethod
component-relative-pathname
((
component
source-file
))
(
defmethod
component-relative-pathname
((
component
source-file
))
(
make-pathname
:name
(
component-name
component
)
(
make-pathname
:name
(
string-unix-common-casify
(
component-name
component
))
:type
(
car
(
rassoc
(
class-name
(
class-of
component
))
:type
(
string-unix-common-casify
(
car
(
rassoc
(
class-name
(
class-of
component
))
*known-extensions*
))))
*known-extensions*
)))
:case
:common
))
(
defclass
c-source-file
(
source-file
)
())
(
defclass
c-source-file
(
source-file
)
())
(
defclass
java-source-file
(
source-file
)
())
(
defclass
java-source-file
(
source-file
)
())
...
@@ -412,10 +424,13 @@
...
@@ -412,10 +424,13 @@
if
b
append
b
into
bindings
if
b
append
b
into
bindings
finally
(
return
(
values
initargs
bindings
))))
finally
(
return
(
values
initargs
bindings
))))
;;; process-option returns as its first value a list of initargs that
;;; eventually gets appended to a call to reinitialize instance; its
;;; optional second value is a list of binding clauses suitable for a
;;; let that may be referred to in the initargs.
(
defmethod
process-option
(
option
value
)
(
defmethod
process-option
(
option
value
)
(
list
option
value
))
(
list
option
value
))
#|
#|
source-file components defined with (:file "a-string") or "a-string"
source-file components defined with (:file "a-string") or "a-string"
will have the string parsed into name and type as if it were a
will have the string parsed into name and type as if it were a
...
@@ -434,7 +449,7 @@ default constituent type.
...
@@ -434,7 +449,7 @@ default constituent type.
(
cond
((
eq
,
keyword
:file
)
(
cond
((
eq
,
keyword
:file
)
(
if
extension
(
if
extension
(
cdr
(
assoc
extension
*known-extensions*
:test
'equal
))
(
cdr
(
assoc
extension
*known-extensions*
:test
'equal
))
(
module-default-component-class
m
)))
(
module-default-component-class
component
)))
((
eq
,
keyword
:module
)
'module
)
((
eq
,
keyword
:module
)
'module
)
(
t
(
intern
(
symbol-name
,
keyword
)
*package*
)))))
(
t
(
intern
(
symbol-name
,
keyword
)
*package*
)))))
;; here's where we use asdf:component. This is probably a
;; here's where we use asdf:component. This is probably a
...
@@ -503,8 +518,20 @@ default constituent type.
...
@@ -503,8 +518,20 @@ default constituent type.
(
defmethod
process-option
((
option
(
eql
:source-pathname
))
value
)
(
defmethod
process-option
((
option
(
eql
:source-pathname
))
value
)
(
list
:pathname
value
))
(
list
:pathname
value
))
(
defmethod
process-option
((
option
(
eql
:source-extension
))
value
)
;; we currently ignore this; arguably we shouldn't.
nil
)
(
defmethod
process-option
((
option
(
eql
:binary-pathname
))
value
)
;; we currently ignore this
nil
)
(
defmethod
process-option
((
option
(
eql
:binary-extension
))
value
)
;; we currently ignore this
nil
)
(
defmethod
process-option
((
option
(
eql
:depends-on
))
value
)
(
defmethod
process-option
((
option
(
eql
:depends-on
))
value
)
(
list
:in-order-to
`
((
compile-system
(
load-system
,@
value
)))))
(
list
:in-order-to
`
'
((
compile-system
(
load-system
,@
value
)))))
;;; initially-do (and finally-do) may need to be moved out of
;;; initially-do (and finally-do) may need to be moved out of
;;; mk-compatibility (or maybe renamed first...)
;;; mk-compatibility (or maybe renamed first...)
...
@@ -529,3 +556,16 @@ default constituent type.
...
@@ -529,3 +556,16 @@ default constituent type.
`
((
#:ignore
`
((
#:ignore
(
defmethod
traverse
:after
((
,
op
load-system
)
(
,
c
(
eql
component
))
(
,
f
(
eql
'perform
)))
(
defmethod
traverse
:after
((
,
op
load-system
)
(
,
c
(
eql
component
))
(
,
f
(
eql
'perform
)))
,
value
))))))
,
value
))))))
(
defmethod
process-option
((
option
(
eql
:load-only
))
value
)
(
let
((
op
(
gensym
"OPERATION"
))
(
c
(
gensym
"COMPONENT"
)))
(
when
value
(
values
nil
`
((
#:ignore
(
defmethod
perform
((
,
op
compile-system
)
(
,
c
(
eql
component
)))
nil
))
(
#:ignore
(
defmethod
output-files
((
,
op
compile-system
)
(
,
c
(
eql
component
)))
(
list
(
component-pathname
,
c
)))))))))
\ No newline at 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