Commit 46bc6c63 authored by Dave Cooper's avatar Dave Cooper
Browse files

added wire-world demo and cleaned up SBCL compile warnings

parent d506336b
......@@ -32,7 +32,7 @@ or <tt>:enterprise</tt>.
Indicates which level of application should be made. Defaults to :development."
application-class :runtime)
(lisp-heap-size 500000000)
(lisp-heap-size 900000000)
(implementation-identifier (glisp:implementation-identifier))
......@@ -97,7 +97,8 @@ temporary directory, returned by <tt>(glisp:temporary-folder)</tt>."
(let ((self (apply #'make-object 'app args)))
(the make!)))
(defun gdl ()
(defun gdl-runtime ()
(let ((destination-directory
(let ((implementation-identifier (glisp:implementation-identifier))
;;(prefix (merge-pathnames "../../staging/" glisp:*genworks-source-home*))
......@@ -107,6 +108,31 @@ temporary directory, returned by <tt>(glisp:temporary-folder)</tt>."
(list :relative
(format nil "~a-~a" implementation-identifier
(glisp:next-datestamp prefix implementation-identifier)))) prefix))))
(app :application-name "gdl-runtime"
:application-class :runtime
:destination-directory destination-directory
:modules (list :agraph)
:restart-init-function '(lambda()
(setq glisp:*gdl-home* (glisp:current-directory))
(setq glisp:*genworks-source-home* (merge-pathnames "src/" glisp:*gdl-home*))
(setq ql:*quicklisp-home* (merge-pathnames "quicklisp/" glisp:*gdl-home*))
(asdf:initialize-output-translations)
(gdl:start-gdl :edition :trial)
(glisp:set-gs-path (merge-pathnames "gpl/gs/gs8.63/bin/gswin32c.exe" glisp:*gdl-home*))))
destination-directory))
(defun gdl ()
(let ((destination-directory
(let ((implementation-identifier (glisp:implementation-identifier))
;;(prefix (merge-pathnames "../../staging/" glisp:*genworks-source-home*))
(prefix (merge-pathnames #+mswindows "c:/staging/" #-mswindows "~/share/staging/")))
(merge-pathnames
(make-pathname :directory
(list :relative
(format nil "~a-~a" implementation-identifier
(glisp:next-datestamp prefix implementation-identifier)))) prefix))))
(app :application-name "gdl"
:application-class :development
:destination-directory destination-directory
......
......@@ -21,7 +21,7 @@
(in-package :com.genworks.lisp)
(eval-when (compile load eval)
(glisp:without-package-variance-warnings
(defpackage :com.genworks.lisp
(:use :common-lisp)
(:export #:copy-directory
......@@ -94,7 +94,7 @@
(let ((class (getf args :application-class)))
(list :runtime (case class
(:development :partners)
(otherwise nil))
(otherwise :standard))
:include-compiler (case class
(:development t)
......
......@@ -37,6 +37,7 @@
:radius 1.5
:length (the :height)
:center (the (:face-center (ecase (the-child :index) (0 :front) (1 :rear))))
:pseudo-inputs (transformation-matrix)
:transformation-matrix
(alignment :front
(rotate-vector-d (the
......
......@@ -21,7 +21,7 @@
(in-package :genworks.demos.bus)
(define-view (html-format assembly) ()
(define-lens (html-format assembly) ()
:output-functions
((model-inputs
......
......@@ -21,7 +21,7 @@
(in-package :genworks.demos.bus)
(define-view (html-format body) nil
(define-lens (html-format body) nil
:output-functions
((model-inputs
......
......@@ -21,7 +21,7 @@
(in-package :genworks.demos.bus)
(define-view (html-format interior) nil
(define-lens (html-format interior) nil
:output-functions
((model-inputs
......
......@@ -22,7 +22,7 @@
(in-package :genworks.demos.bus)
(define-view (html-format rule-ackermann) nil
(define-lens (html-format rule-ackermann) nil
:output-functions
((bottom-user-area
......
......@@ -80,6 +80,7 @@
(translate (the :center) :up (half (the-child :width)))))
(rotate-point-d nominal-center (the :center) (the :y-vector)
:angle (the :reclined-angle)))
:pseudo-inputs (transformation-matrix)
:transformation-matrix (alignment :right
(rotate-vector-d (the :z-vector)
(the :reclined-angle)
......
......@@ -47,6 +47,7 @@
((seats :type 'seat
:sequence (:size (the number-of-rows))
:pass-down (:reclined-angle :max-reclined-angle :x-vector)
:pseudo-inputs (transformation-matrix)
:transformation-matrix
(alignment :rear (the-child y-vector) :right
(the-child x-vector) :top
......
(asdf:defsystem #:gdl-demos :description
"Auto-generated asdf defsys from Genworks GDL cl-lite."
:author
"Genworks and Dave Cooper unless otherwise indicated"
:license "AGPL unless otherwise indicated" :serial t
:version "2011112000" :depends-on (:gdl-gwl-graphics)
:components
((:file "bus/source/package")
(:file "bus/source/assembly")
(:file "bus/source/body")
(:file "bus/source/chassis")
(:file "bus/source/interior")
(:file "bus/source/rule-ackermann")
(:file "bus/source/axle") (:file "bus/source/fleet")
(:file "bus/source/frame-rail")
(:file "bus/source/frame")
(:file "bus/source/html-writer-assembly")
(:file "bus/source/html-writer-body")
(:file "bus/source/html-writer-chassis")
(:file "bus/source/html-writer-interior")
(:file "bus/source/html-writer-rule-ackermann")
(:file "bus/source/inter-seat-clearance-check")
(:file "bus/source/inter-seat-spacing")
(:file "bus/source/knuckle")
(:file "bus/source/parameters")
(:file "bus/source/publish")
(:file "bus/source/rear-axle")
(:file "bus/source/seat")
(:file "bus/source/seating-section")
(:file "bus/source/seating-side")
(:file "bus/source/wheel")
(:file "glassbox/source/assembly")
(:file "glassbox/source/eco-tree")
(:file "ledger/source/package")
(:file "ledger/source/assembly")
(:file "ledger/source/html")
(:file "robot/source/package")
(:file "robot/source/assembly")
(:file "site/source/package")
(:file "site/source/assembly")
(:file "site/source/contact")
(:file "site/source/demos")
(:file "site/source/glossary")
(:file "site/source/index")
(:file "site/source/landing")
(:file "site/source/licensing")
(:file "site/source/maintenance")
(:file "site/source/make")
(:file "site/source/mixins")
(:file "site/source/new")
(:file "site/source/opportunities")
(:file "site/source/options")
(:file "site/source/people")
(:file "site/source/pricing")
(:file "site/source/products")
(:file "site/source/publish")
(:file "site/source/security")))
\ No newline at end of file
(asdf:defsystem #:gdl-demos
:description
"Auto-generated asdf defsys from Genworks GDL cl-lite."
:author
"Genworks and Dave Cooper unless otherwise indicated"
:license
"AGPL unless otherwise indicated"
:serial
t
:version
"2012030300"
:depends-on
(:gdl-gwl-graphics)
:components
((:file "aero-demo-1/source/package")
(:file "aero-demo-1/source/interior-ref-surf")
(:file "aero-demo-1/source/material")
(:file "aero-demo-1/source/parameters")
(:file "aero-demo-1/source/ref-surface")
(:file "aero-demo-1/source/surface-trim")
(:file "aero-demo-1/source/utilities")
(:file "bus/source/package") (:file "bus/source/assembly")
(:file "bus/source/body") (:file "bus/source/chassis")
(:file "bus/source/interior") (:file "bus/source/rule-ackermann")
(:file "bus/source/axle") (:file "bus/source/fleet")
(:file "bus/source/frame-rail") (:file "bus/source/frame")
(:file "bus/source/html-writer-assembly")
(:file "bus/source/html-writer-body")
(:file "bus/source/html-writer-chassis")
(:file "bus/source/html-writer-interior")
(:file "bus/source/html-writer-rule-ackermann")
(:file "bus/source/inter-seat-clearance-check")
(:file "bus/source/inter-seat-spacing")
(:file "bus/source/knuckle") (:file "bus/source/parameters")
(:file "bus/source/publish") (:file "bus/source/rear-axle")
(:file "bus/source/seat") (:file "bus/source/seating-section")
(:file "bus/source/seating-side") (:file "bus/source/wheel")
(:file "glassbox/source/assembly")
(:file "glassbox/source/eco-tree") (:file "ledger/source/package")
(:file "ledger/source/assembly") (:file "ledger/source/html")
(:file "robot/source/package") (:file "robot/source/assembly")
(:file "site/source/package") (:file "site/source/assembly")
(:file "site/source/contact") (:file "site/source/demos")
(:file "site/source/glossary") (:file "site/source/index")
(:file "site/source/landing") (:file "site/source/licensing")
(:file "site/source/maintenance") (:file "site/source/make")
(:file "site/source/mixins") (:file "site/source/new")
(:file "site/source/opportunities") (:file "site/source/options")
(:file "site/source/people") (:file "site/source/pricing")
(:file "site/source/products") (:file "site/source/publish")
(:file "site/source/security")
(:file "wire-world/source/assembly")
(:file "wire-world/source/package")))
\ No newline at end of file
......@@ -54,7 +54,7 @@
(dependency-pairs
(let ((*pairs-hash* (make-hash-table :test #'equalp :values nil)))
(let ((*pairs-hash* (glisp:make-sans-value-hash-table :test #'equalp)))
(the %dependency-pairs%)))
(%dependency-pairs%
......
......@@ -52,6 +52,7 @@
:make-instance-function #'(lambda(type) (the (make-root-instance type))))
(tree :type 'object-tree
:pseudo-inputs (length width)
:tatu-root self
:length (getf (the tree-dimensions) :length)
:width (getf (the tree-dimensions) :width)
......@@ -81,6 +82,7 @@
:tatu-root self)
(inspector :type 'inspector
:pseudo-inputs (length width)
:pass-down (root-object colors-default)
:length (getf (the inspector-dimensions) :length)
:width (getf (the inspector-dimensions) :width)
......@@ -161,7 +163,8 @@ The error was: ~a~%~%" kids-error) "")
object)))
(:uh (the viewport (set-sheet-object! object)))))))
;;(:uh (the viewport (set-sheet-object! object)))
))))
(define-lens (html-format assembly)()
......
......@@ -56,6 +56,7 @@
(color-chooser :type 'color-chooser)
(line-thickness-selectors :type 'vanilla-mixin
:pseudo-inputs (line-thickness)
:sequence (:size 5)
:line-thickness (nth (the-child index) (list 0.5 1.0 2.0 3.0 4.0))
)
......
......@@ -427,6 +427,7 @@
:form-controls (list-elements (the form-fields)))))
(form-fields :type 'text-form-control
:pseudo-inputs (keyword)
:sequence (:size (length (the settables)))
;;
;; FLAG -- precompute this in a slot, and allow for unbound until clicked.
......
......@@ -21,7 +21,7 @@
(in-package :com.genworks.lisp)
(eval-when (:compile-toplevel :load-toplevel :execute)
(glisp:without-package-variance-warnings
(defpackage :com.genworks.lisp
(:use :common-lisp)
(:nicknames :glisp)
......
......@@ -22,7 +22,7 @@
(in-package :gdl)
#-(or allegro lispworks sbcl) (error "Need package for mop:validate-superclass for currently running lisp.~%")
(eval-when (compile load eval)
(eval-when (:compile-toplevel :load-toplevel :execute)
(defpackage :com.genworks.lisp
(:use :common-lisp)
(:shadow #:intern)
......@@ -58,7 +58,8 @@
#:w-o-interrupts
#:xref-off
#:xref-on
#:validate-superclass)))
#:validate-superclass
#:without-package-variance-warnings)))
(in-package :com.genworks.lisp)
......@@ -87,16 +88,17 @@
#-(or allegro lispworks sbcl)
(error "Need parameter for redefinition warnings for currently running lisp.~%")
(let ((original-redefinition-warnings
#+allegro excl:*redefinition-warnings*
#+lispworks lw:*redefinition-action*))
(let (#+(or allegro lispworks)
(original-redefinition-warnings
#+allegro excl:*redefinition-warnings*
#+lispworks lw:*redefinition-action*))
(defun begin-redefinitions-ok ()
#+sbcl (declaim (sb-ext:muffle-conditions sb-ext:compiler-note))
#+sbcl (declare (sb-ext:muffle-conditions sb-ext:compiler-note))
#+(or allegro lispworks)
(setq #+allegro excl:*redefinition-warnings*
#+lispworks lw:*redefinition-action* nil))
(defun end-redefinitions-ok ()
#+sbcl (declaim (sb-ext:unmuffle-conditions sb-ext:compiler-note))
#+sbcl (declare (sb-ext:unmuffle-conditions sb-ext:compiler-note))
#+(or allegro lispworks)
(setq #+allegro excl:*redefinition-warnings*
#+lispworks lw:*redefinition-action* original-redefinition-warnings)))
......@@ -244,7 +246,7 @@
(:case-sensitive-lower string)))
(defmacro w-o-interrupts (&body body)
(warn "Without-interrupts is deprecated in multiprocessing Lisp - replace usage with something else.")
(format t "NOTE: Without-interrupts is deprecated in multiprocessing Lisp - replace usage with something else in glisp:w-o-interrupts.")
#-(or allegro lispworks cmu sbcl) (error "Need implementation for without-interrupts for currently running lisp.~%")
`(#+allegro excl:without-interrupts
#+lispworks progn
......@@ -319,3 +321,7 @@ quicklisp/ directory, with respective copyrights and licenses.
))))
(defmacro without-package-variance-warnings (&body body)
`(eval-when (:compile-toplevel :load-toplevel :execute)
(handler-bind (#+sbcl(sb-int:package-at-variance #'muffle-warning))
,@body)))
\ No newline at end of file
......@@ -76,14 +76,22 @@
(if (eql ,val-arg 'gdl-rule:%not-handled%) (not-handled ,self-arg ,(make-keyword attr-sym)) ,val-arg))))))
`(eval-when (:compile-toplevel :load-toplevel :execute) (glisp:begin-redefinitions-ok))
;;
;; FLAG -- duplicated from inputs.lisp and objects.lisp, functions.lisp, and below in this file.
;;
`(unless nil #+nil (and (fboundp ',(glisp:intern (symbol-name attr-sym) :gdl-inputs))
(find-method (symbol-function ',(glisp:intern (symbol-name attr-sym) :gdl-inputs))
nil (list (find-class 'gdl-basis) (find-class t) (find-class 'gdl-basis)) nil))
(defmethod ,(glisp:intern (symbol-name attr-sym) :gdl-inputs) ((,parent-arg gdl-basis)
,part-arg
(,self-arg gdl-basis))
(declare (ignore ,part-arg))
(let ((,val-arg (getf (the-object ,self-arg %parameters%)
,(make-keyword (symbol-name attr-sym)) 'gdl-rule:%not-handled%)))
(if (eql ,val-arg 'gdl-rule:%not-handled%) (not-handled ,self-arg ,(make-keyword attr-sym)) ,val-arg))))
`(defmethod ,(glisp:intern (symbol-name attr-sym) :gdl-inputs) ((,parent-arg gdl-basis)
,part-arg
(,self-arg gdl-basis))
(declare (ignore ,part-arg))
(let ((,val-arg (getf (the-object ,self-arg %parameters%)
,(make-keyword (symbol-name attr-sym)) 'gdl-rule:%not-handled%)))
(if (eql ,val-arg 'gdl-rule:%not-handled%) (not-handled ,self-arg ,(make-keyword attr-sym)) ,val-arg)))
`(eval-when (:compile-toplevel :load-toplevel :execute) (glisp:end-redefinitions-ok)))))) computed-slots))
......@@ -98,21 +106,32 @@
(list
`(eval-when (:compile-toplevel :load-toplevel :execute) (glisp:begin-redefinitions-ok))
(unless from-objects? ;; DJC trim effort
`(defmethod ,(glisp:intern (symbol-name slot) :gdl-inputs) ((,parent-arg gdl-basis)
,part-arg
(,self-arg gdl-basis))
(declare (ignore ,part-arg))
(let ((,val-arg (getf (the-object ,self-arg %parameters%)
,(make-keyword (symbol-name slot)) 'gdl-rule:%not-handled%)))
(if (eql ,val-arg 'gdl-rule:%not-handled%) (not-handled ,parent-arg ,(make-keyword slot)) ,val-arg))))
;;
;; FLAG -- duplicated from objects.lisp, inputs.lisp, functions.lisp, and above in this file.
;;
`(unless (and (fboundp ',(glisp:intern (symbol-name slot) :gdl-inputs))
(find-method (symbol-function ',(glisp:intern (symbol-name slot) :gdl-inputs))
nil (list (find-class 'gdl-basis) (find-class t) (find-class 'gdl-basis)) nil))
(defmethod ,(glisp:intern (symbol-name slot) :gdl-inputs) ((,parent-arg gdl-basis)
,part-arg
(,self-arg gdl-basis))
(declare (ignore ,part-arg))
(let ((,val-arg (getf (the-object ,self-arg %parameters%)
,(make-keyword (symbol-name slot)) 'gdl-rule:%not-handled%)))
(if (eql ,val-arg 'gdl-rule:%not-handled%) (not-handled ,parent-arg ,(make-keyword slot)) ,val-arg)))))
`(defmethod ,(glisp:intern (symbol-name slot) :gdl-trickle-downs) ((,self-arg gdl-basis) &rest ,args-arg)
(trickle-down-basis ,self-arg ',slot ,args-arg))
`(unless nil #+nil (and (fboundp ',(glisp:intern (symbol-name slot) :gdl-trickle-downs))
(find-method (symbol-function ',(glisp:intern (symbol-name slot) :gdl-trickle-downs))
nil (list (find-class 'gdl-basis)) nil))
(defmethod ,(glisp:intern (symbol-name slot) :gdl-trickle-downs) ((,self-arg gdl-basis) &rest ,args-arg)
(trickle-down-basis ,self-arg ',slot ,args-arg)))
`(defmethod ,(glisp:intern (symbol-name slot) :gdl-slots) ((,self-arg gdl-basis) &rest ,args-arg)
(chase-up-trickle-down ',(glisp:intern (symbol-name slot) :gdl-slots) ,self-arg ,args-arg))
`(unless nil #+nil(and (fboundp ',(glisp:intern (symbol-name slot) :gdl-slots))
(find-method (symbol-function ',(glisp:intern (symbol-name slot) :gdl-slots))
nil (list (find-class 'gdl-basis)) nil))
(defmethod ,(glisp:intern (symbol-name slot) :gdl-slots) ((,self-arg gdl-basis) &rest ,args-arg)
(chase-up-trickle-down ',(glisp:intern (symbol-name slot) :gdl-slots) ,self-arg ,args-arg)))
`(eval-when (:compile-toplevel :load-toplevel :execute) (glisp:end-redefinitions-ok))))))
......
......@@ -98,14 +98,20 @@
,parent-arg (the-object ,self-arg :%name%) ,self-arg)))))
`(eval-when (:compile-toplevel :load-toplevel :execute) (glisp:begin-redefinitions-ok))
`(defmethod ,(glisp:intern (symbol-name attr-sym) :gdl-inputs) ((,parent-arg gdl-basis)
,part-arg
(,self-arg gdl-basis))
(declare (ignore ,part-arg))
(let ((,val-arg (getf (the-object ,self-arg %parameters%)
,(make-keyword (symbol-name attr-sym)) 'gdl-rule:%not-handled%)))
(if (eql ,val-arg 'gdl-rule:%not-handled%) (not-handled ,parent-arg ,(make-keyword attr-sym)) ,val-arg)))
`(eval-when (:compile-toplevel :load-toplevel :execute) (glisp:end-redefinitions-ok)))))))
;;
;; FLAG -- duplicated from inputs.lisp, objects.lisp, and computed-slots.lisp
;;
`(unless (and (fboundp ',(glisp:intern (symbol-name attr-sym) :gdl-inputs))
(find-method (symbol-function ',(glisp:intern (symbol-name attr-sym) :gdl-inputs))
nil (list (find-class 'gdl-basis) (find-class t) (find-class 'gdl-basis)) nil))
(defmethod ,(glisp:intern (symbol-name attr-sym) :gdl-inputs) ((,parent-arg gdl-basis)
,part-arg
(,self-arg gdl-basis))
(declare (ignore ,part-arg))
(let ((,val-arg (getf (the-object ,self-arg %parameters%)
,(make-keyword (symbol-name attr-sym)) 'gdl-rule:%not-handled%)))
(if (eql ,val-arg 'gdl-rule:%not-handled%) (not-handled ,parent-arg ,(make-keyword attr-sym)) ,val-arg))))
`(eval-when (:compile-toplevel :load-toplevel :execute) (glisp:end-redefinitions-ok)))))))
......
......@@ -109,14 +109,23 @@
`(eval-when (:compile-toplevel :load-toplevel :execute) (glisp:begin-redefinitions-ok))
`(defmethod ,(glisp:intern (symbol-name attr-sym) :gdl-inputs) ((,parent-arg gdl-basis)
,part-arg
(,self-arg gdl-basis))
(declare (ignore ,part-arg))
(let ((,val-arg (getf (the-object ,self-arg %parameters%)
,(make-keyword (symbol-name attr-sym)) 'gdl-rule:%not-handled%)))
(if (eql ,val-arg 'gdl-rule:%not-handled%)
(not-handled ,self-arg ,(make-keyword attr-sym)) ,val-arg)))
;;
;; FLAG -- duplicated from objects.lisp
;;
;; FLAG -- avoid duplicate invocation of (glisp:intern (symbol-name ...))
;;
;;
`(unless nil #+nil (and (fboundp ',(glisp:intern (symbol-name attr-sym) :gdl-inputs))
(find-method (symbol-function ',(glisp:intern (symbol-name attr-sym) :gdl-inputs))
nil (list (find-class 'gdl-basis) (find-class t) (find-class 'gdl-basis)) nil))
(defmethod ,(glisp:intern (symbol-name attr-sym) :gdl-inputs) ((,parent-arg gdl-basis)
,part-arg
(,self-arg gdl-basis))
(declare (ignore ,part-arg))
(let ((,val-arg (getf (the-object ,self-arg %parameters%)
,(make-keyword (symbol-name attr-sym)) 'gdl-rule:%not-handled%)))
(if (eql ,val-arg 'gdl-rule:%not-handled%)
(not-handled ,self-arg ,(make-keyword attr-sym)) ,val-arg))))
`(eval-when (:compile-toplevel :load-toplevel :execute) (glisp:end-redefinitions-ok))
......
......@@ -53,7 +53,9 @@
(second (second part-type-expr)))
(t nil))))
(when (and part-type-symbol (not (eql part-type-symbol 'remote-object)))
(when (and part-type-symbol
(atom part-type-symbol)
(not (eql part-type-symbol 'remote-object)))
(let* ((all-inputs (all-inputs part-type-symbol))
(accepted-inputs (if (listp all-inputs)
(append all-inputs pseudo-inputs)
......@@ -193,14 +195,20 @@ item in the list following the :sequence keyword")))))
`(eval-when (:compile-toplevel :load-toplevel :execute) (glisp:begin-redefinitions-ok))
`(defmethod ,(glisp:intern (symbol-name attr-sym) :gdl-inputs) ((,parent-arg gdl-basis)
,part-arg
(,self-arg gdl-basis))
(declare (ignore ,part-arg))
(let ((,val-arg (getf (the-object ,self-arg %parameters%)
,(make-keyword (symbol-name attr-sym)) 'gdl-rule:%not-handled%)))
(if (eql ,val-arg 'gdl-rule:%not-handled%) (not-handled ,parent-arg ,(make-keyword attr-sym))
,val-arg)))
;;
;; FLAG -- duplicated from inputs.lisp
;;
`(unless nil #+nil (and (fboundp ',(glisp:intern (symbol-name attr-sym) :gdl-inputs))
(find-method (symbol-function ',(glisp:intern (symbol-name attr-sym) :gdl-inputs))
nil (list (find-class 'gdl-basis) (find-class t) (find-class 'gdl-basis)) nil))
(defmethod ,(glisp:intern (symbol-name attr-sym) :gdl-inputs) ((,parent-arg gdl-basis)
,part-arg
(,self-arg gdl-basis))
(declare (ignore ,part-arg))
(let ((,val-arg (getf (the-object ,self-arg %parameters%)
,(make-keyword (symbol-name attr-sym)) 'gdl-rule:%not-handled%)))
(if (eql ,val-arg 'gdl-rule:%not-handled%) (not-handled ,parent-arg ,(make-keyword attr-sym))
,val-arg))))
`(eval-when (:compile-toplevel :load-toplevel :execute) (glisp:end-redefinitions-ok))
......
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