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

new automated app build and distro, need to investigate memory consumption issue

parent 152f2e51
......@@ -42,7 +42,7 @@ 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)))
:directory (append (pathname-directory (glisp:temporary-folder)) (the application-name))
:defaults (glisp:temporary-folder)))
(overwrite? t)
......@@ -60,6 +60,8 @@ temporary directory, returned by <tt>(glisp:temporary-folder)</tt>."
(init-file-names (list "gdlinit.cl" ".gdlinit.cl"))
(restart-init-function nil)
(modules nil)
(demo-days 30)
......@@ -86,16 +88,16 @@ temporary directory, returned by <tt>(glisp:temporary-folder)</tt>."
;;
:init-file-names (the init-file-names)
;;
;;:restart-init-function '(lambda()
;; (gdl:start-gdl :edition :open-source))
:restart-init-function (the restart-init-function)
;;
;;
))))
(defun app (&rest args)
(let ((self (apply #'make-object 'make-gdl-app args)))
(let ((self (apply #'make-object 'app args)))
(the make!)))
(defun make-gdl-distro ()
(defun gdl ()
(let ((destination-directory
(let ((implementation-identifier (glisp:implementation-identifier))
(prefix (merge-pathnames "../../staging/" glisp:*genworks-source-home*)))
......@@ -106,7 +108,12 @@ temporary directory, returned by <tt>(glisp:temporary-folder)</tt>."
(glisp:next-datestamp prefix implementation-identifier)))) prefix))))
(app :application-name "gdl"
:application-class :development
:destination-directory destination-directory)
: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*))
(gdl:start-gdl :edition :trial)))
destination-directory))
......
......@@ -24,7 +24,123 @@
(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))))))))
)
\ No newline at end of file
(defun distro (&rest args)
(let ((self (apply #'make-object 'distro args)))
(the make!)))
\ No newline at end of file
......@@ -24,13 +24,28 @@
(eval-when (compile load eval)
(defpackage :com.genworks.lisp
(:use :common-lisp)
(:export #:delete-directory-and-files
(:export #:copy-directory
#:copy-file
#:delete-directory-and-files
#: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)
......
......@@ -21,4 +21,4 @@
(in-package :gdl-user)
(gdl:define-package :gdl-build (:export #:app #:distro #:site))
(gdl:define-package :gdl-build (:export #:app #:gdl #:distro #:site))
......@@ -18,6 +18,8 @@
(t '((acl82m-win-x86 ("../../common/acl82-win-x86/mlisp.exe"))
(acl82a-win-x86 ("../../common/acl82-win-x86/alisp.exe"))))))
(slime-setup '(slime-fancy))
(defun gdl () (interactive) (slime ))
(setq gdl:*gdl-toplevel* (concat "*" "slime-repl " (symbol-name (first (first slime-lisp-implementations))) "*"))
(setq gdl:*inferior-lisp* "*inferior-lisp*")
......
(require 'cl)
(defvar gdl:*gdl-home* (concat default-directory "../"))
(defvar gdl:*gdl-toplevel-base* "*gdl toplevel*")
(defvar gdl:*mgdl-image-name* "gdl")
(load-file (concat gdl:*gdl-home* "emacs/eli/fi-site-init.el"))
(defun gdl () (interactive)
(gdl-devo gdl:*mgdl-image-name*))
(defun gdl-devo (image-name)
(interactive)
(let ((executable (or (fi::probe-file (concat default-directory image-name ".exe"))
(fi::probe-file (concat default-directory image-name)))))
(setq gdl:*gdl-toplevel*
(concat gdl:*gdl-toplevel-base*
(if (equalp (subseq (file-name-sans-extension executable)
0 1) "a")
"(ANSI)" "(modern)")))
(fi:common-lisp gdl:*gdl-toplevel* gdl:*gdl-home* executable nil)))
;;
;; Some handy global keybindings
;;
(defun gdl:global-keys ()
(global-set-key "\M-p" 'fi:pop-input)
(global-set-key "\M-n" 'fi:push-input)
(global-set-key "\C-x&" '(lambda()(interactive) (switch-to-buffer gdl:*gdl-toplevel*)))
(global-set-key "\C-x*" 'fi:open-lisp-listener)
(global-set-key "\C-xy" '(lambda() (interactive) (other-window -1))))
(gdl:global-keys)
;;
;; FLAG -- comment the following if you want a tool bar.
;; (errors ignored in case running in a console terminal)
(ignore-errors (tool-bar-mode -1))
(setq visible-bell t)
;;
;; FLAG -- uncomment the following if you don't need a menu bar.
;; (errors ignored in case running in a console terminal)
;;
;;(ignore-errors (menu-bar-mode -1))
;;
;; Use M-x clear-kill-ring in case you have too much garbage in the
;; kill ring
;;
(defun clear-kill-ring () (interactive) (setq kill-ring nil))
;;
;; FLAG -- you can customize default GDL emacs colors here.
;;
(defun gdl:set-colors ()
(interactive)
(progn
(set-foreground-color "white")
(set-background-color "midnight blue")
(setq default-frame-alist (append default-frame-alist '((background-color . "midnight blue"))))
(set-face-foreground 'default "white")
(set-face-foreground 'font-lock-type-face "hotpink")
(set-face-foreground 'font-lock-keyword-face "Cyan")
(set-face-foreground 'font-lock-string-face "#88FFAA")
(set-face-foreground 'font-lock-function-name-face "#55ff88")
(set-face-foreground 'font-lock-comment-face "#888888")
(set-face-foreground 'font-lock-builtin-face "#ffff99")
(add-to-list 'default-frame-alist '(cursor-color . "RosyBrown4"))
(set-cursor-color "#55FFFF")))
;; ignore errors when setting colors in case of running in console
;; terminal (there's probably a better way to test for this).
(ignore-errors (gdl:set-colors))
(defun gdl:set-font ()
(interactive)
(ignore-errors (set-frame-font "-bitstream-Courier 10 Pitch-normal-normal-normal-*-*-*-*-*-m-0-iso10646-1")))
(gdl:set-font)
(show-paren-mode t)
(defun add-gdl-font-lock-keywords ()
(let ((definition-keywords
(regexp-opt (list "define-object-amendment" "define-object" "define-view" "define-lens" "define-format" "define-skin"
"defpart" "defwriter" "defcompanion" "write-the-object" "write-the"
"the " "the-child" "the-object" "the-element" ) t))
(keyword-keywords
(regexp-opt (list ":documentation"
":input-slots" ":computed-slots" ":objects" ":hidden-objects" ":functions" ":methods"
":output-functions" ":skin" ":trickle-down-slots" ":type" ":sequence"
":size" ":parameters" ":pass-down" ":inputs" ":optional-inputs"
":modifiable-optional-inputs" ":descendant-attributes" ":attributes"
":parts" ":pseudo-parts" ":methods") t)))
(pushnew (list definition-keywords 0 font-lock-keyword-face) lisp-font-lock-keywords)
(pushnew (list keyword-keywords 0 font-lock-type-face) lisp-font-lock-keywords)))
(add-gdl-font-lock-keywords)
(defmacro defindent (name indentation)
(let* ((keyword-list '(lisp-font-lock-keywords t t t nil nil nil "&allow-other-keys"))
(spec (if (eq indentation 'gdl-object-style) `((1 t ,keyword-list) (0 t 2)) indentation)))
`(put ',name 'lisp-indent-hook ',spec)))
(defun gdl:define-indents ()
(defindent define-object gdl-object-style)
(defindent define-view (like define-object))
(defindent define-format (like define-object))
(defindent defpart (like define-object))
(defindent defwriter (like define-object))
(defindent defcompanion (like define-object)))
;;
;; From EvW
;;
(setq next-line-add-newlines nil)
(defun ISO-current-time-string ()
(format-time-string "%Y-%m-%dT%T%z"))
(defun EvW-insert-date ()
"time and date function suggested by Tom Capey (2000-11-28T19:21:04+0100)"
(interactive)
(insert (ISO-current-time-string)))
(defun EvW-save-and-kill-buffer (bufname)
"Saves current buffer, then kills it"
(interactive "b")
(let ((cb (current-buffer)))
(save-buffer cb)
(kill-buffer cb)))
(global-set-key "\M-t" 'EvW-insert-date)
(global-set-key "\C-x\C-k" 'EvW-save-and-kill-buffer)
(defvar font-lock-maximum-decoration t)
(global-font-lock-mode t)
(add-hook 'write-file-hooks 'time-stamp)
(defvar time-stamp-active t)
(defvar time-stamp-format "%3a, %:y-%02m-%02dT%02H:%02M:%02S -- %f")
;; if you encounter a file with ^M or ... at the end of every line,
;; this means a worng copy by samba or floppy disk of the DOS file to UNIX.
;; get rid of them by pressing [F5].
(defun cut-ctrlM ()
(interactive)
(goto-char (point-min));(beginning-of-buffer)
(while (search-forward "\r" nil t)
(replace-match "" nil t))
(not-modified)
(goto-char (point-min)))
(defun replace-ctrlM (ch) ;2001-04-17T17:46:41+0200
(interactive)
"Replace all visible ^M with argument (defaulting to the empty string.)"
(goto-char (point-min))
(while (search-forward "\r" nil t)
(replace-match ch nil t))
;;(not-modified)
(goto-char (point-min)))
(defun remove-trailing-whitespace ()
"Removes trailing blanks and tabs from the buffer."
(interactive)
(save-excursion ;let deactivate-mark nil?
(goto-char (point-min))
(while (re-search-forward "[ \t]+$" nil t)
(replace-match "" nil nil))))
(defun tidy-up ()
"Removes trailing whitespace and ^M from the end of lines.
Bug: does not leave point at the position it had when the function was called"
(interactive)
(save-excursion
(let ((curpos (point)))
(cut-ctrlM)
(remove-trailing-whitespace)
(goto-char curpos))))
;;; EOF
#!/bin/bash
cd `dirname "$0"`/program/
emacs --no-init-file --no-splash -l ../emacs/gdl.el -f gdl
cd %~dp0\program\
%windir%\system32\cmd.exe "/C start ..\gpl\gnu-emacs-23.3\bin\runemacs.exe --no-splash --no-init-file -l ..\emacs\gdl.el" -f gdl
This diff is collapsed.
(asdf:defsystem #:gdl-cl-lite :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-base)
:components
(asdf:defsystem #:gdl-cl-lite :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 "2011111700" :depends-on (:gdl-base :cl-fad)
:components
((:file "source/genworks") (:file "source/cl-lite")))
\ No newline at end of file
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