Commit 0272a167 authored by Dave Cooper's avatar Dave Cooper

Merge branch 'devo' of gitlab.common-lisp.net:gendl/gendl into devo

parents c0cf5c45 b26a6deb
......@@ -105,10 +105,10 @@ loading Glime and Gendl into an emacs environment.
### Further Documentation
Documentation is published
[here](http://genworks.com/downloads/tutorial.pdf), and this very much
[here](http://gen.works/downloads/tutorial.pdf), and this very much
an active work in progress. Training tutorials and videos are also in
progress and in their current state are available in the Documentation
section on http://genworks.com.
section on http://gen.works.
### Support/Community
......@@ -123,7 +123,7 @@ section on http://genworks.com.
* Genworks would like to begin hosting free Gendl/GDL training
seminars in Metro Detroit and possibly other locations. Please
contact [Genworks](http://genworks.com) if you are interested in
contact [Genworks](http://gen.works) if you are interested in
being notified of any upcoming seminars.
......@@ -188,7 +188,7 @@ without the SMLib library and associated middleware available, they
will not be able to return any results. The SMLib kernel and
associated middleware are available as part of the commercial
Genworks® GDL product from [Genworks®
International](http://genworks.com).
International](http://gen.works).
### License
......@@ -205,21 +205,20 @@ distributed at all).
For Proprietary (closed-source) development and distribution, the
commercial Genworks® GDL system (including Gendl® technology and,
optionally, commercial CL engines, technical support, and commercial
solid modeling engine) is available from [Genworks](http://genworks.com).
solid modeling engine) is available from [Genworks](http://gen.works).
### Bug Bounty Program, Bug Fix Program
Genworks offers a modest bounty for reporting (and sometimes solving)
of bugs on the [Issues
List](https://gitlab.common-lisp.net/gendl/gendl/issues?scope=all&state=opened).
Please contact [Genworks](http://gen.works) for details.
### Bug Bounty Program
Genworks offers a modest bounty for reporting of bugs on the [Github
Issues
List](https://github.com/genworks/gendl/issues?state=open). Please
contact [Genworks](http://genworks.com) for details.
### Bug Fix Program
Genworks is open to considering bids for providing cleanly mergeable
fixes to bugs listed on the [Github Issues
List](https://github.com/genworks/gendl/issues?state=open). Please
contact [Genworks](http://genworks.com) for details.
......@@ -29,6 +29,8 @@
(defparameter *index-hash* nil)
(defparameter *footnotes* nil)
(defparameter *footnotetext* nil)
(defparameter *debug-index* nil)
(define-lens (html-format assembly) ()
......@@ -53,12 +55,32 @@
(with-cl-who ()
(:html (:head (:title (str (the title)))
((:link :href (the style-url) :rel "stylesheet" :type "text/css")))
(let ((*index-hash* (make-hash-table :test #'equalp)))
(let ((*index-hash* (make-hash-table :test #'equalp))
(*footnotes* (make-array 50 :adjustable t :fill-pointer 0))
(*footnotetext* nil))
(htm
(:body (:div (write-the cl-who-contents-out))
(:div (write-the cl-who-base))
(when *footnotetext*
(htm (:div (:hr)
(dolist (elements *footnotetext*)
(htm (:p (dolist (element (list-elements elements))
(write-the-object element cl-who-base))))))))
(when (> (length *footnotes*) 0)
(htm (:div (write-the cl-who-footnotes))))
(:div (write-the cl-who-index))))))))
(cl-who-footnotes
()
(with-cl-who ()
(:p (:h2 "Footnotes"))
(loop for elements across *footnotes* as index upfrom 1
do (htm
(:p "[" (:a :name (format nil "FtNt~d" index) :href (format nil "#FtNtR~d" index)
(fmt "~d" index))
"] "
(dolist (element (list-elements elements))
(write-the-object element cl-who-base)))))))
(cl-who-index
()
(with-cl-who ()
......@@ -177,27 +199,66 @@
(dolist (element (list-elements (the elements)))
(write-the-object element cl-who-base)))))
(:emph (htm (:i (dolist (element (list-elements (the elements)))
(write-the-object element cl-who-base)))))
((:emph :i) (htm (:i (dolist (element (list-elements (the elements)))
(write-the-object element cl-who-base)))))
(:textbf (htm (:b (dolist (element (list-elements (the elements)))
(write-the-object element cl-who-base)))))
((:textbf :b) (htm (:b (dolist (element (list-elements (the elements)))
(write-the-object element cl-who-base)))))
(:texttt (htm (:tt (dolist (element (list-elements (the elements)))
(write-the-object element cl-who-base)))))
(:underline (htm (:span :style "text-decoration: underline;"
(dolist (element (list-elements (the elements)))
(write-the-object element cl-who-base)))))
(:quote (htm (:blockquote (dolist (element (list-elements (the elements)))
(write-the-object element cl-who-base)))))
(:index (dolist (element (list-elements (the elements)))
(let* ((data (the-object element data))
(anchor-tag (string (gensym)))
(current (gethash data *index-hash*)))
(if current (pushnew anchor-tag current)
(setf (gethash data *index-hash*) (list anchor-tag)))
(htm ((:a :name anchor-tag))
(write-the-object element cl-who-base)))))
(:copyright (htm "©"))
((:index :indexed)
(dolist (element (list-elements (the elements)))
(let* ((data (the-object element data))
(anchor-tag (string (gensym))))
(push anchor-tag (gethash data *index-hash*))
(htm (:a :name anchor-tag))
(when (eq (the markup-tag) :indexed)
(write-the-object element cl-who-base)))))
(:footnote
(let ((index (1+ (vector-push-extend (the elements) *footnotes*))))
(htm (:a :name (format nil "FtNtR~d" index) :href (format nil "#FtNt~d" index)
(fmt "[~d]" index)))))
(:footnotetext
(push (the elements) *footnotetext*))
((:cite :href)
(let* ((args (list-elements (the elements)))
(target (the-object (car args) data)))
(htm (:a :href (if (eq (the markup-tag) :cite)
(format nil "#~a" target)
target)
(dolist (element (or (cdr args) args))
(write-the-object element cl-who-base))))))
;; :small and :tiny are always used as (:small (:verbatim ...)) and in most browsers,
;; verbatim is already small, so don't do anything.
((:no-op :small :tiny)
(dolist (element (list-elements (the elements)))
(write-the-object element cl-who-base)))
(:include (dolist (element (list-elements (the elements)))
(let ((filename (the-object element data)))
(when (and (> (length filename) 8)
(string= filename "~/gendl/" :end1 8))
(setq filename (merge-pathnames (subseq filename 8)
(asdf:system-source-directory :gendl))))
(with-open-file (s filename)
(let ((buffer (make-string (file-length s))))
(read-sequence buffer s)
(htm (esc buffer)))))))
(otherwise (when *warn-on-unrecognized-tags?*
(warn "Markup tag ~s was not recognized~%" (the markup-tag))))
......
......@@ -69,7 +69,6 @@ o allow input of required input-slots.
(the root-object update!)
(mapsend (list (the tree) (the inspector) (the viewport)) :update!)))
#+nil
(tatu-update-function
#'(lambda()
(the (set-slot! :root-object (the root-object)))
......
......@@ -23,13 +23,17 @@
(in-package :tasty)
(let ((tutorial-file
(or (probe-file (merge-pathnames "../doc/tutorial.pdf" (glisp:executable-homedir-pathname)))
(probe-file (merge-pathnames "gendl/documenation/tutorial/pdf/tutorial.pdf" glisp:*genworks-source-home*))
(warn "tutorial.pdf not found in distribution doc/ directory or source documentation directory for
(defun publish-tutorial (server)
(let ((tutorial-file
(or (probe-file (merge-pathnames "../doc/tutorial.pdf" (glisp:executable-homedir-pathname)))
(probe-file (merge-pathnames "gendl/documenation/tutorial/pdf/tutorial.pdf" glisp:*genworks-source-home*))
(warn "tutorial.pdf not found in distribution doc/ directory or source documentation directory for
publishing in tasty Help menu.~%"))))
(when tutorial-file (publish-file :path "/tutorial.pdf"
:file (namestring (truename tutorial-file)))))
(when tutorial-file (publish-file :path "/tutorial.pdf"
:server server
:file (namestring (truename tutorial-file))))))
(pushnew 'publish-tutorial *publishers*)
(define-object menu-section (sheet-section)
......
......@@ -22,6 +22,9 @@
(in-package :tasty)
(publish-gwl-app "/tasty" "tasty:assembly" :make-object-args (list :title "Genworks tasty"))
(defun publish-tasty (server)
(publish-gwl-app "/tasty" "tasty:assembly" :make-object-args (list :title "Genworks tasty") :server server))
(pushnew 'publish-tasty *publishers*)
......@@ -521,47 +521,48 @@ If you specify :part-symbol-supplied, do not specify :instance-supplied."))
(let ((image-file (the image-file)) (image-format :png)
(pdf-file (merge-pathnames "example.pdf" (glisp:temporary-folder)))
(url (the image-url)) (lisp-file (the lisp-file)))
(publish :path url
:content-type "image/png"
:format :binary
:function #'(lambda(req ent)
(format t "~&~%Loading example code and generating example image for ~s...~%"
(the part-full-symbol))
(the load-example)
(let ((command (format nil "\"~a\" -q -sDEVICE=~a \"-sOutputFile=~a\" -dTextAlphaBits=~a -dGraphicsAlphaBits=~a -dSAFER -dBATCH -dNOPAUSE \"~a\""
*gs-path* (ecase image-format
(:png "png16m")
(:gif "gif")
((:jpg :jpeg) "jpeg"))
image-file
*gs-text-alpha-bits*
*gs-graphics-alpha-bits*
pdf-file)))
(with-all-servers (server)
(publish :path url
:server server
:content-type "image/png"
:format :binary
:function #'(lambda(req ent)
(format t "~&~%Loading example code and generating example image for ~s...~%"
(the part-full-symbol))
(the load-example)
(let ((command (format nil "\"~a\" -q -sDEVICE=~a \"-sOutputFile=~a\" -dTextAlphaBits=~a -dGraphicsAlphaBits=~a -dSAFER -dBATCH -dNOPAUSE \"~a\""
*gs-path* (ecase image-format
(:png "png16m")
(:gif "gif")
((:jpg :jpeg) "jpeg"))
image-file
*gs-text-alpha-bits*
*gs-graphics-alpha-bits*
pdf-file)))
(let ((return-value
(glisp:run-program command :show-window? nil)))
(with-http-response (req ent)
(setf (reply-header-slot-value req :cache-control) "no-cache")
(setf (reply-header-slot-value req :pragma) "no-cache")
(with-http-body (req ent)
(let
((reply-stream (request-reply-stream req)))
(with-open-file
(image-stream image-file :element-type '(unsigned-byte 8))
(do ((val (read-byte image-stream nil nil)
(read-byte image-stream nil nil)))
((null val))
(write-byte val reply-stream))))))
(let ((return-value
(glisp:run-program command :show-window? nil)))
(with-http-response (req ent)
(setf (reply-header-slot-value req :cache-control) "no-cache")
(setf (reply-header-slot-value req :pragma) "no-cache")
(with-http-body (req ent)
(let
((reply-stream (request-reply-stream req)))
(with-open-file
(image-stream image-file :element-type '(unsigned-byte 8))
(do ((val (read-byte image-stream nil nil)
(read-byte image-stream nil nil)))
((null val))
(write-byte val reply-stream))))))
(when (or (null return-value) (zerop return-value))
(delete-file pdf-file)
(delete-file image-file)
(delete-file lisp-file)
(delete-file (make-pathname :name (pathname-name lisp-file)
:type glisp:*fasl-extension*
:directory (pathname-directory lisp-file)
:device (pathname-device lisp-file))))))))
(when (or (null return-value) (zerop return-value))
(delete-file pdf-file)
(delete-file image-file)
(delete-file lisp-file)
(delete-file (make-pathname :name (pathname-name lisp-file)
:type glisp:*fasl-extension*
:directory (pathname-directory lisp-file)
:device (pathname-device lisp-file)))))))))
(push url (gethash (make-keyword (the instance-id)) gwl::*url-hash-table*))
......
......@@ -21,10 +21,14 @@
(in-package :yadd)
(publish-shared :path "/yadd-lookup"
:object-type 'yadd::all)
(with-all-servers (server)
(defun publish-yadd (server)
(publish-shared :path "/yadd-lookup"
:server server
:object-type 'yadd::all)
(publish :path "/user-yadd"
:server server
:function #'(lambda(req ent)
......@@ -37,3 +41,5 @@
:server server
:function #'(lambda(req ent)
(gwl-make-part req ent "yadd:package-dokumentation"))))
(pushnew 'publish-yadd *publishers*)
;;
;; Copyright 2002-2012 Genworks International
;;
;; This source file is part of the General-purpose Declarative
;; Language project (GDL).
;; Except otherwise noted in documentation below, this source file is
;; part of the General-purpose Declarative Language project (GDL).
;;
;; This source file contains free software: you can redistribute it
;; and/or modify it under the terms of the GNU Affero General Public
......@@ -201,27 +201,35 @@ function <b>fn</b> returns non-NIL.
(incf count))))
(defun flatten (tree)
(defun flatten (tree &aux result)
"List. Returns a new list consisting of only the leaf-level atoms from <b>list</b>.
Since nil is technically a list, <tt>flatten</tt> also has the effect of removing
nils from <b>list</b>, but may be inefficient if used only for this purpose. For
removing nil values from a list, consider using <tt>remove nil ...</tt> instead.
:note from On Lisp by Paul Graham, code as follows:
:note from Stack Overflow forum: http://stackoverflow.com/questions/25866292/flatten-a-list-using-common-lisp
<pre>
(if (atom tree)
(ensure-list tree)
(nconc (flatten (car tree))
(if (cdr tree) (flatten (cdr tree)))))
:note Creative Commons license
<pre>
(defun flatten (lst &aux (result '()))
(labels ((rflatten (lst1)
(dolist (el lst1 result)
(if (listp el)
(rflatten el)
(push el result)))))
(nreverse (rflatten lst))))
</pre>
:arguments (list \"List\")
:see-also <tt>remove</tt>"
(if (atom tree)
(ensure-list tree)
(nconc (flatten (car tree))
(if (cdr tree) (flatten (cdr tree))))))
(labels ((rflatten (tree1)
(dolist (el tree1 result)
(if (listp el)
(rflatten el)
(push el result)))))
(nreverse (rflatten tree))))
(defun split (string &optional (split-chars (list #\space #\newline #\return #\tab)))
......@@ -745,6 +753,64 @@ file.
:make-object-args make-object-args :keys-to-ignore keys-to-ignore))))))
(defun read-snapshot-from-stream (in &key object keep-bashed-values? make-object-args keys-to-ignore)
(let ((package-form (read in)))
(when (or (null package-form) (not (find-package (second package-form))))
(error "Invalid package specification at beginning of ~a.~%" filename))
(let* ((*package* (find-package (second package-form))) (root-form (read in)))
(when (or (null root-form)
(not (eql (class-of (find-class (first root-form))) (find-class 'gdl-class))))
(error "Invalid object type specifier as first element of second form in ~a.~%" root-form))
(let* ((object (cond ((and object keep-bashed-values?) object)
(object (the-object object restore-tree!) object)
(t (progn
(apply #'make-object (first root-form) make-object-args))))))
(let ((self object) (value-plist (rest root-form)))
(mapc #'(lambda(key expression)
(unless (member key keys-to-ignore)
(when self (the-object self (set-slot! key (eval expression) :re-sort? nil)))))
(plist-keys value-plist) (plist-values value-plist)))
(let (forms)
(do ((form (read in nil nil) (read in nil nil)))
((null form) forms)
(push form forms))
(setq forms (nreverse forms))
(let* ((forms (double-length-sort forms))
(primaries (remove-if-not #'(lambda(item) (or (getf (rest item) :%primary?%)
(getf (rest item) :element-index-list))) forms))
(non-primaries (remove-if #'(lambda(item) (or (getf (rest item) :%primary?%)
(getf (rest item) :element-index-list))) forms))
(forms (append primaries non-primaries)))
(dolist (form forms)
(let ((root-path (first form)) (value-plist (rest form)))
(let ((self
(with-error-handling (:timeout nil)
(the-object object (follow-root-path root-path)))))
(when self
(mapc #'(lambda(key expression)
(unless (member key keys-to-ignore)
(the-object self (set-slot! key (eval `(let ((self ,self)) ,expression)) :re-sort? nil))))
(plist-keys value-plist) (plist-values value-plist))))))))
object))))
#+nil
(defun read-snapshot-from-stream (in &key object keep-bashed-values? make-object-args keys-to-ignore)
(let (forms)
......
......@@ -575,7 +575,7 @@ Note that this behavior may change to error by default in a future GDL release.
"
message))
(cerror "Set the slot anyway." message))))
(cerror "Set the slot anyway." message))))
(when (and warn-on-non-toplevel?
*notify-cons*)
......@@ -611,16 +611,16 @@ make a fresh root-level object, and start again."))
(let ((slot (glisp:intern (symbol-name attribute) :gdl-acc)))
(unbind-dependent-slots self slot)
(setf (slot-value self slot)
(list value nil t)))
(list value nil t)))
(when remember?
(let ((root (let ((maybe-root (the :root)))
(if (the-object maybe-root root?)
maybe-root
(the-object maybe-root parent))))
(the-object maybe-root parent))))
(root-path (the root-path)
;;(remove :root-object-object (the root-path))
;;(the root-path)
))
;;(remove :root-object-object (the root-path))
;;(the root-path)
))
(cond ((and (gdl-acc::%version-tree% root)
(not (find root-path (gdl-acc::%version-tree% root)
......@@ -629,16 +629,16 @@ make a fresh root-level object, and start again."))
(list (list root-path))))
((null (gdl-acc::%version-tree% root))
(setf (gdl-acc::%version-tree% root)
(list (list root-path)))))
(list (list root-path)))))
(when (the primary?)
(setf (getf (rest (assoc root-path (gdl-acc::%version-tree% root) :test #'equalp)) :%primary?%)
t))
t))
(when re-sort?
(setf (gdl-acc::%version-tree% root)
(double-length-sort (gdl-acc::%version-tree% root)))
(double-length-sort (gdl-acc::%version-tree% root)))
(let ((non-root (remove nil (gdl-acc::%version-tree% root) :key #'first))
(root-list (find nil (gdl-acc::%version-tree% root) :key #'first)))
......@@ -651,11 +651,11 @@ make a fresh root-level object, and start again."))
(getf (rest item) :element-index-list)))
non-root)))
(setf (gdl-acc::%version-tree% root)
(cons (or root-list (list nil))
(append primaries non-primaries))))))
(cons (or root-list (list nil))
(append primaries non-primaries))))))
(setf (getf (rest (assoc root-path (gdl-acc::%version-tree% root) :test #'equalp)) attribute)
value)))
value)))
(when *eager-setting-enabled?*
(dolist (reset *leaf-resets*)
......@@ -898,52 +898,52 @@ demanded. This is useful for updating an existing model or part of an existing
model after making changes and recompiling/reloading the code of the underlying
definitions. Any set (modified) slot values will, however, be preserved
by the update."
update!
(&key (replace-bashed-values? t) immune-message-keys)
(let ((all-messages (the (:message-list)))
(methods (the (:message-list :category :functions)))
(immune-messages (append (list :$$ta2 :$$ta2-object
:$$tatu :$$tatu-object)
(ensure-list immune-message-keys)))
(true-root (if (and (the root parent) (the root parent root?)
(defaulting (the root parent root-object-object))
(eql (the root parent root-object-object) self))
(the root parent) (the root))))
(let ((cached-messages
(set-difference all-messages (append methods immune-messages))))
update!
(&key (replace-bashed-values? t) immune-message-keys)
(let ((all-messages (the (:message-list)))
(methods (the (:message-list :category :functions)))
(immune-messages (append (list :$$ta2 :$$ta2-object
:$$tatu :$$tatu-object)
(ensure-list immune-message-keys)))
(true-root (if (and (the root parent) (the root parent root?)
(defaulting (the root parent root-object-object))
(eql (the root parent root-object-object) self))
(the root parent) (the root))))
(let ((cached-messages
(set-difference all-messages (append methods immune-messages))))
(dolist (key cached-messages)
(let ((key (glisp:intern (symbol-name key) :gdl-acc)))
(unbind-dependent-slots self key :updating? t))))
(let* ( ;;(root-path (remove :root-object-object (the root-path)))
(root-path (the root-path))
(root-path-length (length root-path))
(version-tree
(when replace-bashed-values?
(remove-if-not #'(lambda(node)
(let ((local-root-path (first node)))
(and (> (length local-root-path) root-path-length)
(equalp (subseq local-root-path
(- (length local-root-path)
root-path-length))
root-path))))
(gdl-acc::%version-tree% true-root)))))
(dolist (version-node version-tree (values))
(let ((root true-root)
(root-path (first version-node)) (value-plist (rest version-node)))
(mapc #'(lambda(key value)
(dolist (key cached-messages)
(let ((key (glisp:intern (symbol-name key) :gdl-acc)))
(unbind-dependent-slots self key :updating? t))))
(let* ( ;;(root-path (remove :root-object-object (the root-path)))
(root-path (the root-path))
(root-path-length (length root-path))
(version-tree
(when replace-bashed-values?
(remove-if-not #'(lambda(node)
(let ((local-root-path (first node)))
(and (> (length local-root-path) root-path-length)
(equalp (subseq local-root-path
(- (length local-root-path)
root-path-length))
root-path))))
(gdl-acc::%version-tree% true-root)))))
(dolist (version-node version-tree (values))
(let ((root true-root)
(root-path (first version-node)) (value-plist (rest version-node)))
(mapc #'(lambda(key value)
(when (not (eql value 'gdl-acc::%default%))
;;
;; FLAG - make this into a more specific error check for
;; nonexistence of the object (e.g. not handled error).
;;
(when (not (eql value 'gdl-acc::%default%))
;;
;; FLAG - make this into a more specific error check for
;; nonexistence of the object (e.g. not handled error).
;;
(with-error-handling (:timeout nil)
(the-object root (:follow-root-path root-path)
(:set-slot! key value :re-sort? nil)))))
(plist-keys value-plist) (plist-values value-plist)))))))
(with-error-handling (:timeout nil)
(the-object root (:follow-root-path root-path)
(:set-slot! key value :re-sort? nil)))))
(plist-keys value-plist) (plist-values value-plist)))))))
;;
......@@ -1348,6 +1348,16 @@ a separate object hierarchy." object self)))
(:newline-out
()
(format *stream* "~%"))
(:f
(number &optional columns fraction-columns)
(let ((format-str (format nil "~~~{~a~^,~}f"
(remove nil (list columns fraction-columns)))))
(format *stream* format-str number)))
(:line-feed
()
(format *stream* "~%"))
(:a
(&rest strings)
......
......@@ -186,6 +186,7 @@ If you are interested in this effort we would love to hear from you at open-sour
#:iso-8601-date
#:universal-time-from-iso-8601
#:universal-time-to-plist
#:keywordize-plist
#:lastcar
#:least
#:let-streams
......@@ -928,6 +929,8 @@ If you are interested in this effort we would love to hear from you at open-sour
#:with-html-form
#:publish-shared
#:*publishers*
#:publish-uris