Skip to content
GitLab
Explore
Sign in
Register
Primary navigation
Search or go to…
Project
G
gsll
Manage
Activity
Members
Labels
Plan
Issues
Issue boards
Milestones
Wiki
Code
Merge requests
Repository
Branches
Commits
Tags
Repository graph
Compare revisions
Snippets
Deploy
Releases
Container Registry
Model registry
Monitor
Incidents
Service Desk
Analyze
Value stream analytics
Contributor 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
Antonio Juan
gsll
Commits
e098af31
Commit
e098af31
authored
16 years ago
by
Liam Healy
Browse files
Options
Downloads
Patches
Plain Diff
Merge and clean up the changes to defmfun
Merge and clean up the changes to defmfun.
parent
dfda5c5b
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
init/defmfun.lisp
+61
-36
61 additions, 36 deletions
init/defmfun.lisp
with
61 additions
and
36 deletions
init/defmfun.lisp
+
61
−
36
View file @
e098af31
;; Macro for defining GSL functions.
;; Macro for defining GSL functions.
;; Liam Healy 2008-04-16 20:49:50EDT defmfun.lisp
;; Liam Healy 2008-04-16 20:49:50EDT defmfun.lisp
;; Time-stamp: <2008-08-17 16:
27:48
EDT defmfun.lisp>
;; Time-stamp: <2008-08-17 16:
50:24
EDT defmfun.lisp>
;; $Id$
;; $Id$
(
in-package
:gsl
)
(
in-package
:gsl
)
...
@@ -71,6 +71,12 @@
...
@@ -71,6 +71,12 @@
(
special
indexed-functions
))
(
special
indexed-functions
))
,@
body
))
,@
body
))
(
defparameter
*defmfun-llk*
'
(
&optional
))
(
defun
llkp
(
arglist
)
"There is a lambda-list keyword present."
(
intersection
*defmfun-llk*
arglist
))
(
defun
expand-defmfun-wrap
(
name
arglist
gsl-name
c-arguments
key-args
)
(
defun
expand-defmfun-wrap
(
name
arglist
gsl-name
c-arguments
key-args
)
(
let
(
indexed-functions
)
(
let
(
indexed-functions
)
(
with-defmfun-key-args
key-args
(
with-defmfun-key-args
key-args
...
@@ -83,7 +89,7 @@
...
@@ -83,7 +89,7 @@
(
expand-defmfun-method
name
arglist
gsl-name
c-arguments
key-args
))
(
expand-defmfun-method
name
arglist
gsl-name
c-arguments
key-args
))
((
eq
definition
:methods
)
((
eq
definition
:methods
)
(
expand-defmfun-defmethods
name
arglist
gsl-name
c-arguments
key-args
))
(
expand-defmfun-defmethods
name
arglist
gsl-name
c-arguments
key-args
))
((
and
(
member
'&optional
arglist
)
(
listp
gsl-name
))
((
and
(
llkp
arglist
)
(
listp
gsl-name
))
(
expand-defmfun-optional
name
arglist
gsl-name
c-arguments
key-args
))
(
expand-defmfun-optional
name
arglist
gsl-name
c-arguments
key-args
))
((
eq
definition
:function
)
((
eq
definition
:function
)
(
complete-definition
'cl:defun
name
arglist
gsl-name
c-arguments
key-args
)))
(
complete-definition
'cl:defun
name
arglist
gsl-name
c-arguments
key-args
)))
...
@@ -229,24 +235,43 @@
...
@@ -229,24 +235,43 @@
(
defn
category
name
arglist
gsl-name
c-arguments
key-args
(
defn
category
name
arglist
gsl-name
c-arguments
key-args
&optional
replace-both
)
&optional
replace-both
)
"Create all the methods for a generic function."
"Create all the methods for a generic function."
;; Methods may have &optional in two ways: the optional argument(s)
;; are defaulted if not supplied and a single GSL function called,
;; or the presence/absence of optional arguments switches between two
;; GSL functions.
(
with-defmfun-key-args
key-args
(
with-defmfun-key-args
key-args
(
mapcar
(
lambda
(
eltype
)
(
mapcar
(
lambda
(
eltype
)
(
remf
key-args
:documentation
)
(
flet
((
actual-gfn
(
gslname
)
(
when
(
eq
c-return
:element-c-type
)
(
let
((
gsl-function-name
(
setf
(
getf
key-args
:c-return
)
(
cl-ffa
eltype
)))
(
actual-gsl-function-name
(
when
(
eq
c-return
:component-float-type
)
gslname
category
eltype
)))
(
setf
(
getf
key-args
:c-return
)
(
cl-ffa
(
component-type
eltype
))))
(
push
gsl-function-name
indexed-functions
)
(
complete-definition
gsl-function-name
)))
defn
(
remf
key-args
:documentation
)
(
if
(
eq
defn
:method
)
(
list
nil
name
)
name
)
(
when
(
eq
c-return
:element-c-type
)
(
actual-class-arglist
arglist
eltype
replace-both
)
(
setf
(
getf
key-args
:c-return
)
(
cl-ffa
eltype
)))
(
let
((
gsl-function-name
(
when
(
eq
c-return
:component-float-type
)
(
actual-gsl-function-name
(
setf
(
getf
key-args
:c-return
)
(
cl-ffa
(
component-type
eltype
))))
gsl-name
category
eltype
)))
(
if
(
and
(
llkp
arglist
)
(
listp
(
first
gsl-name
)))
; ad-hoc detection!
(
push
gsl-function-name
indexed-functions
)
;; The methods have optional argument(s) and
gsl-function-name
)
;; multiple GSL functions for presence/absence of
(
actual-element-c-type
eltype
c-arguments
)
;; options
key-args
))
(
complete-definition
defn
(
if
(
eq
defn
:method
)
(
list
nil
name
)
name
)
(
actual-class-arglist
arglist
eltype
replace-both
)
(
mapcar
#'
actual-gfn
gsl-name
)
(
mapcar
(
lambda
(
args
)
(
actual-element-c-type
eltype
args
))
c-arguments
)
key-args
)
(
complete-definition
defn
(
if
(
eq
defn
:method
)
(
list
nil
name
)
name
)
(
actual-class-arglist
arglist
eltype
replace-both
)
(
actual-gfn
gsl-name
)
(
actual-element-c-type
eltype
c-arguments
)
key-args
))))
(
case
element-types
(
case
element-types
((
nil
t
)
*array-element-types*
)
((
nil
t
)
*array-element-types*
)
(
:no-complex
*array-element-types-no-complex*
)
(
:no-complex
*array-element-types-no-complex*
)
...
@@ -294,7 +319,7 @@
...
@@ -294,7 +319,7 @@
(
loop
for
arg
in
arglist
(
loop
for
arg
in
arglist
with
replacing
=
t
with
replacing
=
t
do
do
(
when
(
and
replacing
(
member
arg
'
(
&optional
)
))
(
when
(
and
replacing
(
member
arg
*defmfun-llk*
))
(
setf
replacing
nil
))
(
setf
replacing
nil
))
collect
collect
(
if
(
and
replacing
(
listp
arg
))
(
if
(
and
replacing
(
listp
arg
))
...
@@ -315,8 +340,6 @@
...
@@ -315,8 +340,6 @@
(
coerce
(
second
arg
)
element-type
))
(
coerce
(
second
arg
)
element-type
))
arg
))))
arg
))))
(
defparameter
*defmfun-llk*
'
(
&optional
))
(
defun
arglist-plain-and-categories
(
defun
arglist-plain-and-categories
(
arglist
&optional
(
include-llk
t
))
(
arglist
&optional
(
include-llk
t
))
"Get arglist without classes and a list of categories."
"Get arglist without classes and a list of categories."
...
@@ -402,21 +425,23 @@
...
@@ -402,21 +425,23 @@
(
optional-arglist
(
subseq
arglist
(
1+
optpos
))))
(
optional-arglist
(
subseq
arglist
(
1+
optpos
))))
(
remf
key-args
:documentation
)
(
remf
key-args
:documentation
)
(
setf
indexed-functions
gsl-name
)
(
setf
indexed-functions
gsl-name
)
`
((
defun
,
name
,
arglist
(
let
((
body
,
documentation
`
(
if
,
(
first
optional-arglist
)
(
if
,
(
first
optional-arglist
)
,
(
expand-defmfun-body
,
(
expand-defmfun-body
nil
name
(
append
mandatory-arglist
optional-arglist
)
(
append
mandatory-arglist
optional-arglist
)
(
second
gsl-name
)
(
second
gsl-name
)
(
second
c-arguments
)
(
second
c-arguments
)
key-args
)
key-args
)
,
(
expand-defmfun-body
,
(
expand-defmfun-body
nil
name
mandatory-arglist
mandatory-arglist
(
first
gsl-name
)
(
first
gsl-name
)
(
first
c-arguments
)
(
first
c-arguments
)
key-args
))))
key-args
)))))))))
(
if
(
defgeneric-method-p
name
)
body
`
((
defun
,
name
,
arglist
,
documentation
,@
body
)))))))))
;;;;****************************************************************************
;;;;****************************************************************************
;;;; A single function
;;;; A single function
...
...
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