Commit cfa5a6fe authored by Dave Cooper's avatar Dave Cooper
Browse files

Loads as a pure asdf/quicklisp project from gdl-all.asd; no more load.lisp.

parent 0bdb2e2f
......@@ -128,7 +128,21 @@
;; smlib shared library
;;
(ensure-directories-exist (merge-pathnames "SMLib8.18/" (the target-parent)))
(let ((smlib-name (if (find-package :smlib) (funcall (read-from-string "glisp:smlib-name"))
(error "smlib-name not known (smlib module probably not loaded)."))))
(glisp:copy-file (merge-pathnames (format nil "../../common/SMLib8.18/~a" smlib-name)
glisp:*genworks-source-home*)
(merge-pathnames (format nil "SMLib8.18/~a" smlib-name)
(the target-parent))))
;;
#+nil
(ensure-directories-exist (merge-pathnames "SMLib8.40/" (the target-parent)))
#+nil
(let ((smlib-name (if (find-package :smlib) (funcall (read-from-string "glisp:smlib-name"))
(error "smlib-name not known (smlib module probably not loaded)."))))
(glisp:copy-file (merge-pathnames (format nil "../../common/SMLib8.40/libs/~a/~a"
......
......@@ -18,11 +18,12 @@
((:div :class "about_top")
((:div :class "about_bottom")
((:a :href "http://planet.lisp.org") ((:img :src "http://xach.com/img/jmc.jpg" :alt "John C McCarthy")))))
;;((:a :href (the home url)) ((:img :src "/site-static/images/icons/robot.gif" :alt "")))
;;((:a :href "http://planet.lisp.org") ((:img :src "http://xach.com/img/jmc.jpg" :alt "John C McCarthy")))
((:a :href (the home url)) ((:img :src "/site-static/images/icons/robot.gif" :alt "")))
))
((:div :class "about_top_left")
((:div :class "about_bottom_left")
......
;;
;; Copyright 2002, 2009 Genworks International and Genworks BV
;;
;; 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
;; License as published by the Free Software Foundation, either
;; version 3 of the License, or (at your option) any later version.
;;
;; This source file is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;; Affero General Public License for more details.
;;
;; You should have received a copy of the GNU Affero General Public
;; License along with this source file. If not, see
;; <http://www.gnu.org/licenses/>.
;;
(in-package :gdl-user)
(define-object tatu-test (gwl:base-html-sheet)
:computed-slots
((list-test '(:a36 nil nil "W3b") :settable)
(nil-test nil :settable)
(keyword-test :a36 :settable)
(string-test "hello" :settable)
(number-test 45 :settable)))
(in-package :gwl-user)
(define-object tatu-children (base-html-sheet)
:computed-slots
((length 1 :settable)
(width 2 :settable)
(height 3 :settable)
(aapple (i-dont-know-how 1 2 3))
)
;; It would be great to be able to see kids 1-3 even though 4 can't appear. Then you can use
;; tatu to help track down the error that feeds kid-4's part type.
:objects
((kid-1 :type 'my-box
:pass-down (:length :width :height))
(kid-2 :type 'my-box
:pass-down (:length :width :height))
(kid-3 :type 'my-box
:pass-down (:length :width)
:height (error "This will cause all of the children not to appear This will cause all of the children not to appear This will cause all of the children not to appear This will cause all of the children not to appear This will cause all of the children not to appear"))
(kid-4 :type (if (> (the kid-3 volume) 10)
'my-box
'box)
:pass-down (:length :width :height))
(kid-5 :type 'my-box
:sequence (:size 5)
:display-controls (if (= (the-child index) 4)
(error "Can't compute display-controls")
(list :color :green))
:strings-for-display (if (= (the-child index) 3)
(error "Can't compute strings-for-display")
(format nil "kid-5 ~a" (the-child index))))
(kid-6 :type 'tatu-children)
))
(define-object my-box (box))
(define-object draw-error (base-object)
:objects
((box :type 'box
:height 20
:width 10
:length 10
:display-controls (list :color :green)
:center (translate (the center) :left 25))
(box-1 :type 'box
:height 1 ;;(/ 1 0)
:width 10
:length 10)))
(define-object measure-distance (base-object)
:objects
((left-box :type 'box
:display-controls (list :color :red)
:length 10 :width 20 :height 30
:center (translate (the center) :left 100))
(left-center-box :type 'box
:display-controls (list :color :orange)
:length 10 :width 20 :height 30
:center (translate (the center) :left 50))
(right-box :type 'box
:display-controls (list :color :green)
:length 10 :width 20 :height 30
:center (translate (the center) :right 100))
(right-center-box :type 'box
:display-controls (list :color :blue)
:length 10 :width 20 :height 30
:center (translate (the center) :right 50))
))
......@@ -41,6 +41,7 @@
#:display-startup-banner
#:end-redefinitions-ok
#:eql-specializer
#:featurep
#:gl-class-name
#:gl-method-specializers
#:hex-string-to-integer
......@@ -138,6 +139,12 @@
#+sbcl (sb-mop:intern-eql-specializer attr-sym))
#-(or allegro lispworks sbcl) (error "Need implementation of featurep for currently running lisp.~%")
(defun featurep (x)
(#+allegro excl:featurep #+lispworks system:featurep #+sbcl sb-int:featurep x))
(defun gl-class-name (class)
"Return the class name."
(#-cmu class-name #+cmu mop:class-name class))
......
......@@ -75,7 +75,7 @@
,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)) ,val-arg))))))
`(eval-when (compile load eval) (glisp:begin-redefinitions-ok))
`(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
......@@ -84,7 +84,7 @@
(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 load eval) (glisp:end-redefinitions-ok)))))) computed-slots))
`(eval-when (:compile-toplevel :load-toplevel :execute) (glisp:end-redefinitions-ok)))))) computed-slots))
(defun trickle-down-slots-section (slots &key from-objects?)
......@@ -96,7 +96,7 @@
(remove
nil
(list
`(eval-when (compile load eval) (glisp:begin-redefinitions-ok))
`(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
......@@ -115,5 +115,5 @@
(chase-up-trickle-down ',(glisp:intern (symbol-name slot) :gdl-slots) ,self-arg ,args-arg))
`(eval-when (compile load eval) (glisp:end-redefinitions-ok))))))
`(eval-when (:compile-toplevel :load-toplevel :execute) (glisp:end-redefinitions-ok))))))
slots))
......@@ -97,7 +97,7 @@
(,(glisp:intern (symbol-name attr-sym) :gdl-inputs)
,parent-arg (the-object ,self-arg :%name%) ,self-arg)))))
`(eval-when (compile load eval) (glisp:begin-redefinitions-ok))
`(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))
......@@ -105,7 +105,7 @@
(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 load eval) (glisp:end-redefinitions-ok)))))))
`(eval-when (:compile-toplevel :load-toplevel :execute) (glisp:end-redefinitions-ok)))))))
......
......@@ -62,11 +62,11 @@
(let ((*error-on-not-handled?* t)) ,expr))
`(eval-when (compile load eval) (glisp:begin-redefinitions-ok))
`(eval-when (:compile-toplevel :load-toplevel :execute) (glisp:begin-redefinitions-ok))
;;`(defgeneric ,(glisp:intern (symbol-name input-sym) :gdl-slots) (self &rest ,args-arg))
`(eval-when (compile load eval) (glisp:end-redefinitions-ok))
`(eval-when (:compile-toplevel :load-toplevel :execute) (glisp:end-redefinitions-ok))
`(when (or (not (fboundp ',(glisp:intern (symbol-name input-sym) :gdl-slots)))
......@@ -107,7 +107,7 @@
(the-object ,parent-arg (fetch-input ,(make-keyword attr-sym) ,part-arg ,self-arg))))
`(eval-when (compile load eval) (glisp:begin-redefinitions-ok))
`(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
......@@ -119,7 +119,7 @@
(not-handled ,self-arg ,(make-keyword attr-sym)) ,val-arg)))
`(eval-when (compile load eval) (glisp:end-redefinitions-ok))
`(eval-when (:compile-toplevel :load-toplevel :execute) (glisp:end-redefinitions-ok))
`(defmethod ,(glisp:intern (symbol-name attr-sym) :gdl-slots) ((self ,name) &rest ,args-arg)
(declare (ignore ,args-arg))
......@@ -170,7 +170,7 @@
;; New stuff
;;
`(eval-when (compile load eval) (glisp:begin-redefinitions-ok))
`(eval-when (:compile-toplevel :load-toplevel :execute) (glisp:begin-redefinitions-ok))
(when (and *compile-for-dgdl?* (not (string-equal (symbol-name name) "remote-object") ))
`(when (or (not (fboundp ',(glisp:intern attr-sym :gdl-slots)))
......@@ -196,12 +196,15 @@
`(when (and ,defaulted?
(or (not (fboundp ',(glisp:intern (symbol-name attr-sym) :gdl-trickle-downs)))
(not (find-method (symbol-function ',(glisp:intern (symbol-name attr-sym) :gdl-trickle-downs))
(not (find-method (symbol-function ',(glisp:intern (symbol-name attr-sym)
:gdl-trickle-downs))
nil (list (find-class 'gdl-basis)) nil))))
(defmethod ,(glisp:intern (symbol-name attr-sym) :gdl-trickle-downs) ((,self-arg gdl-basis) &rest ,args-arg)
(defmethod ,(glisp:intern (symbol-name attr-sym) :gdl-trickle-downs)
((,self-arg gdl-basis) &rest ,args-arg)
(declare (ignore ,args-arg))
(not-handled ,self-arg ,(make-keyword attr-sym))))
`(eval-when (compile load eval) (glisp:end-redefinitions-ok))
`(eval-when (:compile-toplevel :load-toplevel :execute) (glisp:end-redefinitions-ok))
`(defmethod ,(glisp:intern (symbol-name attr-sym) :gdl-slots) ((self ,name) &rest ,args-arg)
(declare (ignore ,args-arg))
......
......@@ -191,7 +191,7 @@ item in the list following the :sequence keyword")))))
(the-object ,self-arg (send (:apply (cons ,(make-keyword (symbol-name attr-sym))
,args-arg)))))))
`(eval-when (compile load eval) (glisp:begin-redefinitions-ok))
`(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
......@@ -202,7 +202,7 @@ item in the list following the :sequence keyword")))))
(if (eql ,val-arg 'gdl-rule:%not-handled%) (not-handled ,parent-arg ,(make-keyword attr-sym))
,val-arg)))
`(eval-when (compile load eval) (glisp:end-redefinitions-ok))
`(eval-when (:compile-toplevel :load-toplevel :execute) (glisp:end-redefinitions-ok))
(when (member (first part-quantify-expr) '(:size :radial))
`(defmethod gdl-inputs::number-of-elements ((self ,name) (,part-arg (eql ',attr-sym)) (child t))
......
......@@ -193,7 +193,7 @@ You have a dependency on caffeine. Your children are your dependants.
;;
;; FLAG -- check that remotes are effectively from same tree as well
;;
(or (typep (first *notify-cons*) 'gdl-remote)
(or (and (find-class 'gdl-remote nil) (typep (first *notify-cons*) 'gdl-remote))
(same-tree? ,self-sym (first *notify-cons*))))))
......
......@@ -799,7 +799,7 @@ a separate object hierarchy." object self)))
(if (or updating? (not *remember-previous-slot-values?*))
'gdl-rule::%unbound%
(list 'gdl-rule::%unbound% nil nil (first (slot-value object slot))))))))
(when (typep object 'gdl-remote)
(when (and (find-class 'gdl-remote nil) (typep object 'gdl-remote))
(the-object object (unbind-remote-slot slot)))))))
;;
......
......@@ -88,7 +88,7 @@ given as keyword args to this function)."
:type glisp:*fasl-extension*)))))
(eval-when (compile load eval)
(eval-when (:compile-toplevel :load-toplevel :execute)
(define-object directory-node nil
:input-slots
......@@ -99,11 +99,11 @@ given as keyword args to this function)."
:computed-slots
((device (pathname-device (the ppathname)))
(ppathname (translate-logical-pathname (the pathname)))
(ppathname (probe-file (translate-logical-pathname (the pathname))))
(contents (sort (glisp:directory-list (the ppathname))
#'(lambda (x y)
(string< (file-namestring x) (file-namestring y)))))
(local-name (lastcar (pathname-directory (the ppathname))))
(local-name (lastcar (pathname-directory (or (the ppathname) (the pathname)))))
(subdir-pathnames (mapcar #'pathname-directory
(remove-if-not #'glisp:file-directory-p (the contents)))))
......@@ -215,9 +215,13 @@ Defaults to nil (i.e. we assume we are loading into a clean system and need all
#'string<
:key #'pathname-name))
(asd-file (merge-pathnames (make-pathname :name (string-append "gdl-" (the fasl-output-name))
:type "asd")
(the ppathname)))
(asd-file (let ((asd-file-name
(make-pathname :name (string-append "gdl-" (the fasl-output-name))
:type "asd")))
(or (and (the ppathname)
(merge-pathnames asd-file-name (the ppathname)))
(error "Could not create ~a in ~a.~%Directory does not exist.~%"
asd-file-name (the pathname)))))
(asdf-depends-on (let ((depends-on-file
(merge-pathnames (make-pathname :name "depends-on"
......@@ -227,6 +231,18 @@ Defaults to nil (i.e. we assume we are loading into a clean system and need all
(with-open-file (in depends-on-file)
(read in)))))
(additional-asd-code (let ((asd-code-file
(merge-pathnames (make-pathname :name "additional-asd-code"
:type "isc")
(the ppathname))))
(when (probe-file asd-code-file)
(with-open-file (in asd-code-file)
(let (result)
(let (*read-eval*)
(do ((form (read in nil nil) (read in nil nil)))
((null form) (nreverse result))
(push form result))))))))
(asdf-system-list
(let ((binaries (the compile-and-load)))
(append `(asdf:defsystem ,(read-from-string (format nil "#:~a" (pathname-name (the asd-file))))
......@@ -252,7 +268,6 @@ Defaults to nil (i.e. we assume we are loading into a clean system and need all
"\\" "/"))))
binaries))))
:uncached))
:hidden-objects
((subdir-computation :type 'subdir-computation
......@@ -280,8 +295,12 @@ Defaults to nil (i.e. we assume we are loading into a clean system and need all
(with-open-file (out (the asd-file) :direction :output
:if-exists :supersede
:if-does-not-exist :create)
(let ((*print-right-margin* 70))
(pprint (the asdf-system-list) out)))
(let ((*print-right-margin* 70)
(*print-case* :downcase))
(pprint (the asdf-system-list) out)
(when (the additional-asd-code)
(format out "~%~%")
(pprint (the additional-asd-code) out))))
(the asd-file))
......@@ -318,7 +337,7 @@ Defaults to nil (i.e. we assume we are loading into a clean system and need all
:device (the :device)
:name (pathname-name file)
:type (the :fasl-type))))
(let ((output-date (file-write-date output-file))
(let ((output-date (when (probe-file output-file) (file-write-date output-file)))
(file-date (file-write-date file)))
(when (and (not dry-run?)
(or (null output-date) (<= output-date file-date)))
......
......@@ -78,7 +78,9 @@
(defun directory-list (pathspec)
(directory pathspec #+allegro :directories-are-files #+allegro nil))
(ql-impl-util:directory-entries pathspec)
;;(directory pathspec #+allegro :directories-are-files #+allegro nil)
)
;;
;; temporary-folder is potentially platform-specific so it is defined here.
......
(:gdl-cl-lite :cl-typesetting)
(:gdl-cl-lite :cl-typesetting :gdl-cl-typesetting-ql-patch)
(asdf:defsystem #:gdl-geom-base :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 "2011101700" :depends-on
(:gdl-cl-lite :cl-typesetting) :components
((:file "prereqs/source/cl-pdf-patches")
(:file "prereqs/source/matrix")
(:file "prereqs/source/genworks")
(:file "prereqs/source/package")
(:file "prereqs/source/parameters")
(:file "prereqs/source/utilities")
(:file "formats/source/2d-output")
(:file "formats/source/dxf")
(:file "formats/source/macro-redefs")
(:file "formats/source/obj")
(:file "formats/source/pdf-multipage")
(:file "formats/source/pdf-raw")
(:file "formats/source/pdf")
(:file "formats/source/png")
(:file "formats/source/raster")
(:file "formats/source/vector-graphics")
(:file "formats/source/vrml")
(:file "wire/source/base-object")
(:file "wire/source/arc")
(:file "wire/source/cylinder")
(:file "wire/source/global-polyline")
(:file "wire/source/global-filleted-polyline")
(:file "wire/source/global-polygon-projection")
(:file "wire/source/sphere")
(:file "wire/source/l-line")
(:file "wire/source/circle")
(:file "wire/source/arcoid-mixin")
(:file "wire/source/bezier-curve")
(:file "wire/source/bounding-box")
(:file "wire/source/box")
(:file "wire/source/c-cylinder")
(:file "wire/source/cone")
(:file "wire/source/directional-light")
(:file "wire/source/ellipse")
(:file "wire/source/fillet")
(:file
"wire/source/global-filleted-polygon-projection")
(:file "wire/source/null-geometric-object")
(:file "wire/source/outline-specialization-mixin")
(:file "wire/source/point-light")
(:file "wire/source/point")
(:file "wire/source/points-display")
(:file "wire/source/primitives")
(:file "wire/source/route-pipe")
(:file "wire/source/spherical-cap")
(:file "wire/source/spot-light")
(:file "wire/source/torus")
(:file "wire/source/views")
(:file "annotations/source/angular-dimension")
(:file "annotations/source/arrowhead")
(:file "annotations/source/center-line")
(:file "annotations/source/horizontal-dimension")
(:file "annotations/source/label")
(:file "annotations/source/leader-arc")
(:file "annotations/source/leader-line")
(:file "annotations/source/linear-dimension")
(:file "annotations/source/package")
(:file "annotations/source/parallel-dimension")
(:file "annotations/source/sample-drawing")
(:file "annotations/source/vertical-dimension")
(:file "drawing/source/base-view")
(:file "drawing/source/document")
(:file "drawing/source/lenses")
(:file "drawing/source/renderer-mixin")
(:file "text/source/general-note")
(:file "text/source/typeset-block")
(:file "graphs/source/graph")
(:file "graphs/source/legend")
(:file "graphs/source/pie-chart")
(:file "math/source/polynomial")))
(asdf:defsystem #:gdl-geom-base
: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
"2011121800"
:depends-on
(:gdl-cl-lite :cl-typesetting :gdl-cl-typesetting-ql-patch)
:components
((:file "prereqs/source/cl-pdf-patches")
(:file "prereqs/source/matrix")
(:file "prereqs/source/genworks")
(:file "prereqs/source/package")
(:file "prereqs/source/parameters")
(:file "prereqs/source/utilities")
(:file "formats/source/2d-output")
(:file "formats/source/dxf")
(:file "formats/source/macro-redefs")
(:file "formats/source/obj")
(:file "formats/source/pdf-multipage")
(:file "formats/source/pdf-raw")
(:file "formats/source/pdf")
(:file "formats/source/png")
(:file "formats/source/raster")
(:file "formats/source/vector-graphics")
(:file "formats/source/vrml")
(:file "wire/source/base-object")
(:file "wire/source/arc")
(:file "wire/source/cylinder")
(:file "wire/source/global-polyline")
(:file "wire/source/global-filleted-polyline")
(:file "wire/source/global-polygon-projection")
(:file "wire/source/sphere")
(:file "wire/source/l-line")
(:file "wire/source/circle")
(:file "wire/source/arcoid-mixin")
(:file "wire/source/bezier-curve")
(:file "wire/source/bounding-box")
(:file "wire/source/box")
(:file "wire/source/c-cylinder")
(:file "wire/source/cone")
(:file "wire/source/directional-light")
(:file "wire/source/ellipse")
(:file "wire/source/fillet")
(:file "wire/source/global-filleted-polygon-projection")
(:file "wire/source/null-geometric-object")
(:file "wire/source/outline-specialization-mixin")
(:file "wire/source/point-light")
(:file "wire/source/point")
(:file "wire/source/points-display")
(:file "wire/source/primitives")
(:file "wire/source/route-pipe")
(:file "wire/source/spherical-cap")
(:file "wire/source/spot-light")
(:file "wire/source/torus")
(:file "wire/source/views")
(:file "annotations/source/angular-dimension")
(:file "annotations/source/arrowhead")
(:file "annotations/source/center-line")
(:file "annotations/source/horizontal-dimension")
(:file "annotations/source/label")
(:file "annotations/source/leader-arc")
(:file "annotations/source/leader-line")
(:file "annotations/source/linear-dimension")