Commit 7a5808d5 authored by Dave Cooper's avatar Dave Cooper

added a few more.

parent 4ed848e6
(:gendl :cl-markdown)
\ No newline at end of file
(:gendl :gendl-asdf :cl-markdown)
\ No newline at end of file
;;;; -*- coding: utf-8 -*-
(asdf:defsystem #:gendl-asdf
:description "asdf gendl artifacts loading"
:serial t
:version "20161111"
:depends-on ()
:components ((:file "gendl-asdf")))
;;;; -*- 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)))
;;;; -*- 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 "20200820" :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 "20201012" :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")))
......@@ -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"
......
......@@ -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)))
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment