Skip to content
GitLab
Projects
Groups
Snippets
Help
Loading...
Help
What's new
7
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Contribute to GitLab
Sign in / Register
Toggle navigation
Open sidebar
gendl
gendl-patches
gendl-patches
Commits
7a5808d5
Commit
7a5808d5
authored
Oct 16, 2020
by
Dave Cooper
Browse files
Options
Browse Files
Download
Email Patches
Plain Diff
added a few more.
parent
4ed848e6
Changes
6
Hide whitespace changes
Inline
Side-by-side
Showing
6 changed files
with
113 additions
and
11 deletions
+113
-11
depends-on.isc
depends-on.isc
+1
-1
gendl-asdf.asd
gendl-asdf.asd
+8
-0
gendl-asdf.lisp
gendl-asdf.lisp
+26
-0
gendl-patches.asd
gendl-patches.asd
+10
-10
source/cl-lite.gendl
source/cl-lite.gendl
+9
-0
source/gdl.lisp
source/gdl.lisp
+59
-0
No files found.
depends-on.isc
View file @
7a5808d5
(:gendl :cl-markdown)
\ No newline at end of file
(:gendl :gendl-asdf :cl-markdown)
\ No newline at end of file
gendl-asdf.asd
0 → 100644
View file @
7a5808d5
;;;; -*- coding: utf-8 -*-
(
asdf:defsystem
#:gendl-asdf
:description
"asdf gendl artifacts loading"
:serial
t
:version
"20161111"
:depends-on
()
:components
((
:file
"gendl-asdf"
)))
gendl-asdf.lisp
0 → 100644
View file @
7a5808d5
;;;; -*- coding: utf-8 -*-
(
in-package
:asdf
)
(
defclass
asdf::gdl
(
asdf::cl-source-file
)
((
type
:initform
"gdl"
)))
(
defclass
asdf::gendl
(
asdf::cl-source-file
)
((
type
:initform
"gendl"
)))
(
defclass
asdf::lisp
(
asdf::cl-source-file
)
())
(
defclass
asdf::table
(
asdf::cl-source-file
)
((
type
:initform
"table"
)))
(
defmethod
perform
((
o
compile-op
)
(
c
asdf::table
))
(
perform-peruse-file
o
c
))
(
defmethod
perform
((
o
load-op
)
(
c
asdf::table
))
(
perform-peruse-file
o
c
))
(
defun
perform-peruse-file
(
o
c
)
"Perform the perusal of icad-style catalog table."
(
declare
(
ignore
o
))
(
let
((
input-file
(
slot-value
c
'asdf/component:absolute-pathname
)))
(
gendl::peruse-file
input-file
:load
t
)))
gendl-patches.asd
View file @
7a5808d5
;;;; -*- coding: utf-8 -*-
(
asdf:defsystem
#:gendl-patches
:description
"The Gendl® gendl-patches Subsystem"
:author
"Genworks International"
:license
"Affero Gnu Public License (http://www.gnu.org/licenses/)"
:serial
t
:version
"2020
0820
"
:depends-on
(
:gendl
:cl-markdown
)
:defsystem-depends-on
nil
:components
((
:file
"source/aserve"
)
(
:gendl
"source/cl-lite"
)
(
:file
"source/gdl"
)
(
:file
"source/glisp"
)
(
:file
"source/gwl"
)))
;;;; -*- coding: utf-8 -*-
(
asdf:defsystem
#:gendl-patches
:description
"The Gendl® gendl-patches Subsystem"
:author
"Genworks International"
:license
"Affero Gnu Public License (http://www.gnu.org/licenses/)"
:serial
t
:version
"2020
1012
"
:depends-on
(
:gendl
:cl-markdown
)
:defsystem-depends-on
nil
:components
((
:file
"source/aserve"
)
(
:gendl
"source/cl-lite"
)
(
:file
"source/gdl"
)
(
:file
"source/glisp"
)
(
:file
"source/gwl"
)))
source/cl-lite.gendl
View file @
7a5808d5
...
...
@@ -27,6 +27,15 @@
;; FLAG -- Merged but delete commented-out old code in devo 2020-08-20
;;
(define-object-amendment codebase-directory-node ()
:objects
((source-files :type 'file
:files (append (getf (the file-computation relevant-files) :source)
(getf (the file-computation relevant-files) :tables))
:pseudo-inputs (files)
:sequence (:size (length (the-child files)))
:pathname (nth (the-child index) (the-child files))))
:computed-slots
((asdf-defsystem-depends-on
(let ((sexpr (glisp:sexpr-from-file (merge-pathnames (make-pathname :name "defsystem-depends-on"
...
...
source/gdl.lisp
View file @
7a5808d5
...
...
@@ -342,3 +342,62 @@ This function will be run in the initiating image after the build is finished."
(
export
'
(
theo
thech
le
)
:gendl
))
;;
;; Already merged into devo (below is coming from codebase)
;;
(
#+
allegro
excl:without-package-locks
#-
allegro
progn
(
defun
computed-slots-section
(
name
computed-slots
&key
query?
)
(
mapcan
#'
(
lambda
(
attribute
)
(
let
((
attr-remarks
(
message-strings
attribute
))
(
attr-sym
(
intern
(
symbol-name
(
message-symbol
attribute
))
:gdl-acc
))
(
attr-expr
(
message-source-code
attribute
)))
(
remove
nil
(
list
(
when
(
and
name
*compile-documentation-database?*
attr-remarks
)
`
(
when
*load-documentation-database?*
(
let
((
ht
(
or
(
message-documentation
(
find-class
',name
))
(
setf
(
message-documentation
(
find-class
',name
))
(
make-hash-table
)))))
(
setf
(
gethash
(
make-keyword
',attr-sym
)
ht
)
,
attr-remarks
))))
(
when
(
and
name
*compile-source-code-database?*
)
`
(
when
*load-source-code-database?*
(
let
((
ht
(
or
(
message-source
(
find-class
',name
))
(
setf
(
message-source
(
find-class
',name
))
(
make-hash-table
)))))
(
setf
(
gethash
(
make-keyword
',attr-sym
)
ht
)
',attr-expr
))))
(
when
name
`
(
defmethod
,
(
glisp:intern
(
symbol-name
attr-sym
)
:gdl-slots
)
((
self
,
name
)
&rest
,
args-arg
)
(
declare
(
ignore
,
args-arg
))
(
let
((
*error-on-not-handled?*
t
))
(
with-dependency-tracking
(
,
attr-sym
)
,
(
if
query?
`
(
iq:qlet
(())
,
attr-expr
)
attr-expr
))
#+
nil
(
with-dependency-tracking
(
,
attr-sym
)
,
(
if
query?
(
error
"Query-slots are not supported in this distribution of Genworks GDL."
)
attr-expr
)))))
(
when
(
and
*compile-for-dgdl?*
(
not
(
string-equal
(
symbol-name
name
)
"remote-object"
)))
`
(
when
(
or
(
not
(
fboundp
',
(
glisp:intern
attr-sym
:gdl-slots
)))
(
not
(
find-method
(
symbol-function
',
(
glisp:intern
attr-sym
:gdl-slots
))
nil
(
list
(
find-class
'gdl-remote
))
nil
)))
(
defmethod
,
(
glisp:intern
attr-sym
:gdl-slots
)
((
,
self-arg
gdl-remote
)
&rest
,
args-arg
)
(
the-object
,
self-arg
(
send
(
:apply
(
cons
,
(
make-keyword
(
symbol-name
attr-sym
))
,
args-arg
)))))))
(
unless
query?
`
(
unless
(
find-method
(
symbol-function
',
(
glisp:intern
(
symbol-name
attr-sym
)
:gdl-slots
))
nil
(
list
(
find-class
'gdl-basis
))
nil
)
(
defmethod
,
(
glisp:intern
(
symbol-name
attr-sym
)
:gdl-slots
)
((
,
self-arg
gdl-basis
)
&rest
,
args-arg
)
;;(declare (ignore ,args-arg))
(
let
((
,
parent-arg
(
the-object
,
self-arg
%parent%
)))
(
if
(
or
(
null
,
parent-arg
)
,
args-arg
)
(
not-handled
,
self-arg
,
(
make-keyword
attr-sym
)
,
args-arg
)
(
let
((
,
val-arg
(
let
(
*error-on-not-handled?*
)
(
,
(
glisp:intern
(
symbol-name
attr-sym
)
:gdl-inputs
)
,
parent-arg
(
the-object
,
self-arg
:%name%
)
,
self-arg
))))
(
if
(
eql
,
val-arg
'gdl-rule:%not-handled%
)
(
not-handled
,
self-arg
,
(
make-keyword
attr-sym
)
,
args-arg
)
,
val-arg
)))))))))))
computed-slots
)))
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