Skip to content
GitLab
Explore
Sign in
Primary navigation
Search or go to…
Project
cmucl
Manage
Activity
Members
Labels
Plan
Issues
Issue boards
Milestones
Wiki
External wiki
Code
Merge requests
Repository
Branches
Commits
Tags
Repository graph
Compare revisions
Snippets
Build
Pipelines
Jobs
Pipeline schedules
Artifacts
Deploy
Releases
Model registry
Operate
Environments
Monitor
Incidents
Analyze
Value stream analytics
Contributor analytics
CI/CD analytics
Repository analytics
Model experiments
Help
Help
Support
GitLab documentation
Compare GitLab plans
GitLab community forum
Contribute to GitLab
Provide feedback
Terms and privacy
Keyboard shortcuts
?
Snippets
Groups
Projects
Show more breadcrumbs
cmucl
cmucl
Commits
ffe3625a
Commit
ffe3625a
authored
Aug 29, 2023
by
Raymond Toy
Browse files
Options
Downloads
Patches
Plain Diff
Address
#240
: Rename processing macros for set operations
parent
4542d55e
Branches
Branches containing commit
Tags
Tags containing commit
1 merge request
!171
Address #240: Rename processing macros for set operations
Changes
1
Show whitespace changes
Inline
Side-by-side
Showing
1 changed file
src/code/list.lisp
+60
-38
60 additions, 38 deletions
src/code/list.lisp
with
60 additions
and
38 deletions
src/code/list.lisp
+
60
−
38
View file @
ffe3625a
...
...
@@ -753,26 +753,31 @@
union
intersection
set-difference
nunion
nintersection
nset-difference
))
;; Main code to process a set function. INIT-RES initializes the
;; value of RES, which holds the result of the set function.
;; TEST-FORM is a form that tests whether to add the item from LIST1
;; to RES.
(
defmacro
process-set-body
(
init-res
invert-p
test-form
)
;; Handle a non-destructive set operation. LIST1 and LIST2 are the
;; two arguments to the set function. INITIAL-RESULT is the value
;; used to initialize the result list. IS specifies whether the test
;; (or test-not) function implies an element of LIST1 should be
;; included in the result.
(
defmacro
do-set-operation
(
list1
list2
&key
initial-result
is
)
(
let
((
membership-test
(
ecase
is
(
:element-of-set
'when
)
(
:not-element-of-set
'unless
))))
`
(
let
((
hashtable
(
list-to-hashtable
,
list2
key
test
test-not
)))
(
macrolet
((
process-set-op
(
list1
init-res
member-form
test-form
)
`
(
let
((
res
,
init-res
))
(
dolist
(
item
list1
)
(
when
,
(
if
invert-p
`
(
not
,
test-form
)
test-form
)
(
dolist
(
item
,
list1
)
(
,
member-form
,
test-form
(
push
item
res
)))
res
))
res
))
)
(
defmacro
process-set
(
init-res
invert-p
)
`
(
let
((
hashtable
(
list-to-hashtable
list2
key
test
test-not
)))
(
if
hashtable
(
process-set-
body
,
init-res
,
invert-p
(
process-set-
op
,
list1
,
init
ial
-res
ult
,
membership-test
(
nth-value
1
(
gethash
(
apply-key
key
item
)
hashtable
)))
(
process-set-
body
,
init-res
,
invert-p
(
with-set-keys
(
member
(
apply-key
key
item
)
list2
))))))
(
process-set-
op
,
list1
,
init
ial
-res
ult
,
membership-test
(
with-set-keys
(
member
(
apply-key
key
item
)
list2
))))))
))
;; Convert a list to a hashtable. The hashtable does not handle
;; duplicated values in the list. Returns the hashtable.
...
...
@@ -815,7 +820,7 @@
(
declare
(
inline
member
))
(
when
(
and
testp
notp
)
(
error
(
intl:gettext
"Test and test-not both supplied."
)))
(
process-set
list2
t
))
(
do-set-operation
list1
list2
:initial-result
list2
:is
:not-element-of-se
t
))
(
defun
intersection
(
list1
list2
&key
key
...
...
@@ -824,7 +829,7 @@
(
declare
(
inline
member
))
(
if
(
and
testp
notp
)
(
error
"Test and test-not both supplied."
))
(
process-set
nil
nil
))
(
do-set-operation
list1
list2
:initial-result
nil
:is
:element-of-set
))
(
defun
set-difference
(
list1
list2
&key
key
(
test
#'
eql
testp
)
(
test-not
nil
notp
))
"Returns the elements of list1 which are not in list2."
...
...
@@ -835,7 +840,7 @@
(
when
(
null
list2
)
(
return-from
set-difference
list1
))
(
process-set
nil
t
))
(
do-set-operation
list1
list2
:initial-result
nil
:is
:not-element-of-se
t
))
;;; Destination and source are setf-able and many-evaluable. Sets the source
...
...
@@ -851,14 +856,14 @@
;;; the result list. INVERT-P is T if the result of the TEST-FORM
;;; should be inverted. TEST-FORM is the form used for determining
;;; how to update the result.
(
defmacro
nprocess-set-body
(
init-res
i
nv
er
t
-p
test-form
)
(
defmacro
nprocess-set-body
(
list1
init-res
i
s-memb
er-p
test-form
)
`
(
let
((
res
,
init-res
)
(
list1
list1
))
(
list1
,
list1
))
(
do
()
((
endp
list1
))
(
if
,
(
if
i
nv
er
t
-p
`
(
not
,
test-form
)
test-form
)
(
if
,
(
if
i
s-memb
er-p
test-form
`
(
not
,
test-form
)
)
(
steve-splice
list1
res
)
(
setq
list1
(
cdr
list1
))))
res
))
...
...
@@ -867,13 +872,30 @@
;; initializes the value of the result list. INVERT-P indicates
;; whether to invert the test-form used to determine how the result
;; should be updated.
(
defmacro
nprocess-set
(
init-res
invert-p
)
`
(
let
((
hashtable
(
list-to-hashtable
list2
key
test
test-not
)))
(
defmacro
do-destructive-set-operation
(
list1
list2
&key
initial-result
is
)
(
let
((
is-member-p
(
ecase
is
(
:element-of-set
t
)
(
:not-element-of-set
nil
))))
`
(
let
((
hashtable
(
list-to-hashtable
,
list2
key
test
test-not
)))
(
macrolet
((
process-set-op
(
list1
init-res
is-member-p
test-form
)
`
(
let
((
res
,
init-res
)
(
list1
,
list1
))
(
do
()
((
endp
list1
))
(
if
,
(
if
is-member-p
test-form
`
(
not
,
test-form
))
(
steve-splice
list1
res
)
(
setq
list1
(
cdr
list1
))))
res
)))
(
if
hashtable
(
n
process-set-
body
,
init-res
,
inv
er
t
-p
(
nth-value
1
(
gethash
(
apply-key
key
(
car
list1
))
hashtable
)))
(
n
process-set-
body
,
init-res
,
inv
er
t
-p
(
with-set-keys
(
member
(
apply-key
key
(
car
list1
))
list2
))))))
(
process-set-
op
,
list1
,
init
ial
-res
ult
,
is-memb
er-p
(
nth-value
1
(
gethash
(
apply-key
key
(
car
,
list1
))
hashtable
)))
(
process-set-
op
,
list1
,
init
ial
-res
ult
,
is-memb
er-p
(
with-set-keys
(
member
(
apply-key
key
(
car
,
list1
))
list2
))))))
))
(
defun
nunion
(
list1
list2
&key
key
(
test
#'
eql
testp
)
(
test-not
nil
notp
))
...
...
@@ -882,7 +904,7 @@
(
if
(
and
testp
notp
)
(
error
"Test and test-not both supplied."
))
(
nprocess-set
list2
t
))
(
do-destructive-set-operation
list1
list2
:initial-result
list2
:is
:not-element-of-se
t
))
(
defun
nintersection
(
list1
list2
&key
key
(
test
#'
eql
testp
)
(
test-not
nil
notp
))
...
...
@@ -891,7 +913,7 @@
(
if
(
and
testp
notp
)
(
error
"Test and test-not both supplied."
))
(
nprocess-set
nil
nil
))
(
do-destructive-set-operation
list1
list2
:initial-result
nil
:is
:element-of-set
))
(
defun
nset-difference
(
list1
list2
&key
key
(
test
#'
eql
testp
)
(
test-not
nil
notp
))
...
...
@@ -900,7 +922,7 @@
(
if
(
and
testp
notp
)
(
error
"Test and test-not both supplied."
))
(
nprocess-set
nil
t
))
(
do-destructive-set-operation
list1
list2
:initial-result
nil
:is
:not-element-of-se
t
))
(
declaim
(
end-block
))
...
...
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
sign in
to comment