Skip to content
GitLab
Explore
Sign in
Register
Primary navigation
Search or go to…
Project
A
alexandria
Manage
Activity
Members
Labels
Plan
Issues
Issue boards
Milestones
Wiki
Code
Merge requests
Repository
Branches
Commits
Tags
Repository graph
Compare revisions
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
Christophe Junke
alexandria
Commits
7a095a28
Commit
7a095a28
authored
15 years ago
by
Attila Lendvai
Browse files
Options
Downloads
Patches
Plain Diff
added assoc-value (written by John Fremlin)
parent
13cfae2b
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
lists.lisp
+39
-0
39 additions, 0 deletions
lists.lisp
with
39 additions
and
0 deletions
lists.lisp
+
39
−
0
View file @
7a095a28
...
@@ -22,6 +22,45 @@ property list PLIST in the same order."
...
@@ -22,6 +22,45 @@ property list PLIST in the same order."
((
safe-endp
tail
)
(
nreverse
alist
))
((
safe-endp
tail
)
(
nreverse
alist
))
(
push
(
cons
(
car
tail
)
(
cadr
tail
))
alist
))))
(
push
(
cons
(
car
tail
)
(
cadr
tail
))
alist
))))
(
declaim
(
inline
racons
))
(
defun
racons
(
key
value
ralist
)
(
acons
value
key
ralist
))
(
macrolet
((
define-alist-get
(
name
get-pair
get-value-from-pair
add
doc
)
`
(
progn
(
declaim
(
inline
,
name
))
(
defun
,
name
(
alist
key
&key
(
test
'eql
))
,
doc
(
let
((
pair
(
,
get-pair
key
alist
:test
test
)))
(
values
(
,
get-value-from-pair
pair
)
pair
)))
(
define-setf-expander
,
name
(
place
key
&key
(
test
'
'eql
)
&environment
env
)
(
multiple-value-bind
(
dummies
vals
newvals
setter
getter
)
(
get-setf-expansion
place
env
)
(
when
(
cdr
newvals
)
(
error
"~A cannot store multiple values in one place"
',name
))
(
with-unique-names
(
store
key-val
test-val
alist
found
)
(
values
(
append
dummies
(
list
key-val
test-val
))
(
append
vals
(
list
key
test
))
(
list
store
)
`
(
let
((
,
alist
,
getter
))
(
let
((
,
found
(
,
',get-pair
,
key-val
,
alist
:test
,
test-val
)))
(
cond
(
,
found
(
setf
(
,
',get-value-from-pair
,
found
)
,
store
))
(
t
(
let
,
newvals
(
setf
,
(
first
newvals
)
(
,
',add
,
key
,
store
,
alist
))
,
setter
)))
,
store
))
`
(
,
',name
,
getter
,
key
))))))))
(
define-alist-get
assoc-value
assoc
cdr
acons
"ASSOC-VALUE is an alist accessor very much like ASSOC, but it can
be used with SETF."
)
(
define-alist-get
rassoc-value
rassoc
car
racons
"RASSOC-VALUE is an alist accessor very much like RASSOC, but it can
be used with SETF."
))
(
defun
malformed-plist
(
plist
)
(
defun
malformed-plist
(
plist
)
(
error
"Malformed plist: ~S"
plist
))
(
error
"Malformed plist: ~S"
plist
))
...
...
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