Commit 4e3e3bc9 authored by Teodor Gelu Chiciudean's avatar Teodor Gelu Chiciudean
Browse files

Merge remote-tracking branch 'upstream/master'

parents fa4282c3 aa4b39d0
......@@ -3,6 +3,8 @@
*.fasl
bin
*~
.DS_Store
# Ignore (generated) html files,
# *.html
......
......@@ -7,4 +7,4 @@
:version "2011101800" :depends-on (:gdl-base)
:components
((:file "source/package") (:file "source/genworks")
(:file "source/make-gdl-app")))
\ No newline at end of file
(:file "source/app") (:file "source/distro")))
\ No newline at end of file
(in-package :gdl-build)
(defun make-gdl-app (&rest args)
(let ((self (apply #'make-object 'make-gdl-app args)))
(the make!)))
(define-object make-gdl-app ()
:input-slots
(("String. The name which will be used for your application's executable and dxl file.
Defaults to \"gdl-base.\""
application-name "gdl-base")
("Keyword symbol. Should be one of <tt>:runtime</tt>, <tt>:development</tt>,
or <tt>:enterprise</tt>.
Indicates which level of application should be made. Defaults to :development."
application-class :development)
("Pathname. Indicates the directory to be created or overwritten for producing
the distribution.
Defaults to a directory called <tt>(the application-name)</tt> in the user
temporary directory, returned by <tt>(glisp:temporary-folder)</tt>."
destination-directory
(merge-pathnames (make-pathname :directory (list :relative (the application-name)))
(glisp:temporary-folder) ))
(pre-load-form `(progn (load ,(merge-pathnames "load.lisp"
glisp:*genworks-source-home*))
(setf (symbol-value (read-from-string
"glisp:*genworks-source-home*")) nil)
(setf (symbol-value (read-from-string
"asdf:*central-registry*")) nil)))
(post-load-form nil)
;;
;; FLAG -- leave this to nil for now while we are working on the basic build.
;;
(init-file-names (list "gdlinit.cl" ".gdlinit.cl"))
(modules nil)
(demo-days 30)
)
:functions
((make!
()
(when (probe-file (the destination-directory))
(glisp:delete-directory-and-files (the destination-directory)))
(glisp:make-gdl-app :application-name (the application-name)
:destination-directory (the destination-directory)
:modules (the modules)
:pre-load-form (the pre-load-form)
:post-load-form (the post-load-form)
:application-class (the application-class)
:demo-days (the demo-days)
;;
;; FLAG -- leave this to nil for now while we are working
;; on the basic build.
;;
:init-file-names (the init-file-names)
;;
;;:restart-init-function '(lambda()
;; (gdl:start-gdl :edition :open-source))
;;
))))
(defun make-gdl-site ()
(gdl-build:make-gdl-app :post-load-form '(progn
(load "~/genworks-1581-pre-git/gdl/dist/src/demos/site/gdl-site.asd")
(asdf:load-system :gdl-site)
(load "~/genworks-1580/gdl/apps/downloads/gdl-downloads.asd")
(asdf:load-system :gdl-downloads))
:demo-days nil))
\ No newline at end of file
;;
;; Copyright 2002-2011 Genworks International and Genworks BV
;;
;; This source file is part of the General-purpose Declarative
;; Language project (GDL).
;;
;; 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-build)
(define-object app ()
:input-slots
(("String. The name which will be used for your application's executable and dxl file.
Defaults to \"my-gdl-app\""
application-name "my-gdl-app")
("Keyword symbol. Should be one of <tt>:runtime</tt>, <tt>:development</tt>,
or <tt>:enterprise</tt>.
Indicates which level of application should be made. Defaults to :development."
application-class :runtime)
(lisp-heap-size 500000000)
(implementation-identifier (glisp:implementation-identifier))
("Pathname. Indicates the directory to be created or overwritten for producing
the distribution.
Defaults to a directory called <tt>(the application-name)</tt> in the user
temporary directory, returned by <tt>(glisp:temporary-folder)</tt>."
destination-directory
(make-pathname :name nil :type nil
:directory (append (pathname-directory (glisp:temporary-folder)) (the application-name))
:defaults (glisp:temporary-folder)))
(overwrite? t)
(load-core-gdl-form `(progn (load ,(merge-pathnames "../../common/build"
glisp:*genworks-source-home*))
(setf (symbol-value (read-from-string
"glisp:*genworks-source-home*")) nil)
(setf (symbol-value (read-from-string
"asdf:*central-registry*")) nil)))
(pre-load-form (the load-core-gdl-form))
(post-load-form nil)
(init-file-names (list "gdlinit.cl" ".gdlinit.cl"))
(restart-init-function nil)
(modules nil)
(demo-days 30)
)
:functions
((make!
()
(when (and (probe-file (the destination-directory)) (the overwrite?))
(glisp:delete-directory-and-files (the destination-directory)))
(glisp:make-gdl-app :application-name (the application-name)
:destination-directory (the destination-directory)
:modules (the modules)
:pre-load-form (the pre-load-form)
:post-load-form (the post-load-form)
:application-class (the application-class)
:demo-days (the demo-days)
:lisp-heap-size (the lisp-heap-size)
;;
;; FLAG -- leave this to nil for now while we are working
;; on the basic build.
;;
:init-file-names (the init-file-names)
;;
:restart-init-function (the restart-init-function)
;;
;;
))))
(defun app (&rest args)
(let ((self (apply #'make-object 'app args)))
(the make!)))
(defun gdl ()
(let ((destination-directory
(let ((implementation-identifier (glisp:implementation-identifier))
(prefix (merge-pathnames "../../staging/" glisp:*genworks-source-home*)))
(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
: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*))
(gdl:start-gdl :edition :trial)
(glisp:set-gs-path (merge-pathnames "gpl/gs/gs8.63/bin/gswin32c.exe" glisp:*gdl-home*))))
destination-directory))
(defun site ()
(app :post-load-form
'(progn
(require :smtp)
(require :ftp)
(load (merge-pathnames "demos/gdl-demos.asd" glisp:*genworks-source-home*))
(asdf:load-system :gdl-demos)
(load (merge-pathnames "../downloads/gdl-downloads.asd"))
(asdf:load-system :gdl-downloads))
:destination-directory
(merge-pathnames "../../staging/site/" glisp:*genworks-source-home*)
:overwrite? t
:application-name "genworks-site"
:application-class :development
:demo-days nil
:restart-init-function '(lambda()
(gdl:start-gdl :edition :trial)
(glisp:set-gs-path
#+mswindows (merge-pathnames "gpl/gs/gs8.63/bin/gswin32c.exe" glisp:*gdl-home*)))))
;;
;; Copyright 2002-2011 Genworks International and Genworks BV
;;
;; This source file is part of the General-purpose Declarative
;; Language project (GDL).
;;
;; 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-build)
(define-object distro ()
:input-slots
((overwrite? nil)
(staging-directory (merge-pathnames "../../staging/" glisp:*genworks-source-home*))
(release-directory (merge-pathnames "../../release/" glisp:*genworks-source-home*))
(release-name-mapping '(("acl-8.2m-linux-x86" . "gdl1581-linux")
("acl-8.2m-win-x86" . "gdl1581-windows")))
(os-name-mapping '(("win" . "windows")
("linux" . "linux")
("macos" . "macos")))
(known-releases (mapcar #'first (the release-name-mapping))))
:computed-slots
((staging-release-pairs (let (result)
(dolist (entry (glisp:directory-list (the staging-directory)) (nreverse result))
(when (glisp:file-directory-p entry)
(let* ((full-name (lastcar (pathname-directory entry)))
(base (subseq full-name 0 (- (length full-name)
(length "-2011010100")))))
(when (member base (the known-releases) :test #'string-equal)
(push (cons entry
(merge-pathnames (format nil "~a/~a~a/program/"
(the (os-name-lookup base))
(rest (assoc base (the release-name-mapping)
:test #'string-equal))
(subseq full-name (length base)))
(the release-directory))) result))))))))
:objects
((pairs :type 'staging-release-pair
:sequence (:size (length (the staging-release-pairs)))
:pair (nth (the-child index) (the staging-release-pairs))
:pass-down (overwrite?)))
:functions
((os-name-lookup
(base)
(dolist (mapping (the os-name-mapping))
(when (search (first mapping) base) (return (rest mapping)))))
(make!
()
(dolist (pair (list-elements (the pairs))) (the-object pair make!)))))
(define-object staging-release-pair ()
:input-slots (pair overwrite?)
:computed-slots ((source (first (the pair)))
(target (rest (the pair)))
(target-parent (merge-pathnames "../" (the target)))
(os (lastcar (butlast (pathname-directory (the target-parent))))))
:functions
((make!
()
(when (and (probe-file (the target)) (the overwrite?))
(glisp:delete-directory-and-files (the target-parent) :quiet t))
(unless (probe-file (the target-parent))
(glisp:copy-directory (the source) (the target))
;;
;; Documentation:
;;
(ensure-directories-exist (merge-pathnames "documentation/" (the target-parent)))
(glisp:copy-file (merge-pathnames "documentation/gdl-documentation.pdf" glisp:*genworks-source-home*)
(merge-pathnames "documentation/gdl-documentation.pdf" (the target-parent)))
;;
;; GDL source code:
;;
(glisp:copy-directory glisp:*genworks-source-home*
(merge-pathnames "src/" (the target-parent)))
(glisp:delete-directory-and-files (merge-pathnames "src/.git/" (the target-parent)) :quiet t)
(delete-file (merge-pathnames "src/.gitignore" (the target-parent)))
;;
;; Quicklisp:
;;
(glisp:copy-directory (merge-pathnames "../../common/quicklisp/" glisp:*genworks-source-home*)
(merge-pathnames "quicklisp/" (the target-parent)))
;;
;; eli:
;;
(ensure-directories-exist (merge-pathnames "emacs/" (the target-parent)))
(glisp:copy-directory (translate-logical-pathname "sys:eli;")
(merge-pathnames "emacs/eli/" (the target-parent)))
(glisp:copy-file (merge-pathnames "dist/emacs/gdl.el" glisp:*genworks-source-home*)
(merge-pathnames "emacs/gdl.el" (the target-parent)))
;;
;; Startup batch file or script:
;;
(if (string-equal (the os) "windows")
(glisp:copy-file (merge-pathnames "dist/run-gdl.bat" glisp:*genworks-source-home*)
(merge-pathnames "run-gdl.bat" (the target-parent)))
(glisp:copy-file (merge-pathnames "dist/run-gdl" glisp:*genworks-source-home*)
(merge-pathnames "run-gdl" (the target-parent))))
;;
;; smlib shared library
;;
(ensure-directories-exist (merge-pathnames "SMLib8.18/" (the target-parent)))
(glisp:copy-file (merge-pathnames (format nil "../../common/SMLib8.18/~a" (glisp:smlib-name))
glisp:*genworks-source-home*)
(merge-pathnames (format nil "SMLib8.18/~a" (glisp:smlib-name))
(the target-parent)))
;;
;; gpl on windows
;;
(when (string-equal (the os) "windows")
(glisp:copy-directory (merge-pathnames "../../common/gpl/" glisp:*genworks-source-home*)
(merge-pathnames "gpl/" (the target-parent))))))))
(defun distro (&rest args)
(let ((self (apply #'make-object 'distro args)))
(the make!)))
\ No newline at end of file
;;
;; Copyright 2002-2011 Genworks International and Genworks BV
;;
;; This source file is part of the General-purpose Declarative
;; Language project (GDL).
;;
;; 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 :com.genworks.lisp)
(eval-when (compile load eval)
(defpackage :com.genworks.lisp
(:use :common-lisp)
(:export #:make-gdl-app
#:delete-directory-and-files
(:export #:copy-directory
#:copy-file
#:delete-directory-and-files
#:dump-memory
#:implementation-identifier
#:make-gdl-app
#:next-datestamp
)))
(defun copy-file (from to &key overwrite?)
(fad:copy-file from to :overwrite overwrite?))
;;
;; FLAG -- replace with cl-fad version.
;;
(defun copy-directory (from-dir to-dir &rest args)
(declare (ignore args))
#+allegro (excl:copy-directory from-dir to-dir)
#+lispworks (cl-copy-directory to-dir from-dir)
#+clozure (ccl::recursive-copy-directory from-dir to-dir ))
#-(or allegro (and unix lispworks))
(warn "~&Please implement delete-directory-and-files for the currently running lisp.~%")
(defun delete-directory-and-files (target &key force quiet if-does-not-exist)
#+lispworks (declare (ignore force quiet if-does-not-exist))
#+lispworks (system:run-shell-command (format nil "rm -rf ~a" target))
#+allegro (excl.osi:delete-directory-and-files
target :force force :quiet quiet :if-does-not-exist if-does-not-exist))
#+(and mswindows allegro)
(ff:def-foreign-call (memory-status-dump "memory_status_dump") ())
(defun dump-memory (&key (output-name "mem")
(output-type "txt")
(output-path (merge-pathnames (make-pathname :name output-name
:type output-type)
(glisp:temporary-folder))))
#+(and mswindows allegro)
(let ((status (memory-status-dump (namestring (translate-logical-pathname output-path)))))
(unless (zerop status) (error "~&memory-status-dump failed with non-zero return code: ~a~%~%" status))
output-path)
#-(and mswindows allegro) (declare (ignore output-path))
#-(and mswindows allegro)
(error "Need implementation of dump-memory for currently running lisp."))
(defun implementation-identifier ()
(asdf::implementation-identifier))
#-allegro(warn "~&Please implement generate-application for the currently running lisp.~%")
(defun make-gdl-app (&rest args)
#+allegro
......@@ -39,6 +108,8 @@
glisp:*genworks-source-home*)
:demo (getf args :demo-days)
:lisp-heap-size (getf args :lisp-heap-size)
:close-oldspace t
:init-file-names (getf args :init-file-names)
:pre-load-form (getf args :pre-load-form)
:post-load-form (getf args :post-load-form)
......@@ -50,13 +121,47 @@
(defun next-datestamp (prefix base)
(let* ((base-length (length base))
(directory (directory prefix))
(files (mapcar #'(lambda(item)
(let ((name (pathname-name item))
(type (pathname-type item)))
(format nil "~a~a~a" name
(if type "." "")
(or type "")))) directory))
(matches (sort (remove-if-not #'(lambda(file)
(and (> (length file) base-length)
(string-equal (subseq file 0 base-length) base))) files)
#'string-greaterp))
(datestamps (remove
nil
(mapcar #'(lambda(match)
(let ((datestamp (subseq match (1+ base-length))))
(if (not (get-decoded-datestamp datestamp))
(warn "Invalid datestamp ~a on file ~a in directory ~a.~%"
datestamp match prefix) datestamp))) matches)))
(latest (first datestamps)))
(multiple-value-bind (latest-serial-number latest-date latest-month latest-year)
(when latest (get-decoded-datestamp latest))
(multiple-value-bind (seconds minutes hours date month year) (get-decoded-time)
(declare (ignore seconds minutes hours))
(let ((new-serial-number (if (and latest (= latest-date date)
(= latest-month month) (= latest-year year))
(1+ latest-serial-number) 0)))
(format nil "~a~2,'0d~2,'0d~2,'0d" year month date new-serial-number))))))
#-(or allegro (and unix lispworks))
(warn "~&Please implement delete-directory-and-files for the currently running lisp.~%")
(defun delete-directory-and-files (target &key force quiet if-does-not-exist)
#+lispworks (declare (ignore force quiet if-does-not-exist))
#+lispworks (system:run-shell-command (format nil "rm -rf ~a" target))
#+allegro (excl.osi:delete-directory-and-files
target :force force :quiet quiet :if-does-not-exist if-does-not-exist))
(defun get-decoded-datestamp (datestamp)
(let (*read-eval*)
(when (and (= (length datestamp) 10)
(integerp (read-from-string datestamp)))
(let ((year (read-from-string (subseq datestamp 0 4)))
(month (read-from-string (subseq datestamp 4 6)))
(date (read-from-string (subseq datestamp 6 8)))
(serial-number (read-from-string (subseq datestamp 8 10))))
(when (ignore-errors (encode-universal-time 0 0 0 date month year))
(values serial-number date month year))))))
;;
;; Copyright 2002-2011 Genworks International and Genworks BV
;;
;; This source file is part of the General-purpose Declarative
;; Language project (GDL).
;;
;; 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)
(gdl:define-package :gdl-build (:export #:make-gdl-app #:make-gdl-site))
(gdl:define-package :gdl-build (:export #:app #:gdl #:distro #:site))
(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 "2011102000" :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 "ledger/source/package")
(:file "ledger/source/assembly")
(:file "ledger/source/html")
(:file "robot/source/package")
(:file "robot/source/assembly")))
\ 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 "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")