Commit 1f4c642a authored by Dave Cooper's avatar Dave Cooper
Browse files

fixed png image output in yadd

parent 4b349a0a
......@@ -2,4 +2,16 @@
cd `dirname "$0"`
/Applications/Aquamacs.app/Contents/MacOS/Aquamacs --no-splash --no-init-file -l devo.el -f slime $@
os_platform=`uname`
export cl_platform=''
if [ "$os_platform" == "Linux" ]; then
cl_platform='Allegro'
emacs --no-splash --no-init-file -l devo.el $@
elif [ "$os_platform" == "Darwin" ]; then
cl_platform='LispWorks'
/Applications/Aquamacs.app/Contents/MacOS/Aquamacs --no-splash --no-init-file -l devo.el $@
fi
(load (expand-file-name "~/quicklisp/slime-helper.el"))
(setq inferior-lisp-program "~/bin/lw-console")
;;
;; FLAG -- learn how to add command line args to inferior-lisp-program
;; to load load.lisp for Genworks GDL automatically.
;;
(if (string= (getenv "cl_platform") "LispWorks")
(setq inferior-lisp-program "~/bin/lw-console")
(if (string= (getenv "cl_platform") "Allegro")
(setq inferior-lisp-program "/usr/local/acl/mlisp")
(error "Don't know what CL executable to use")))
(defun gdl () (interactive) (slime))
(setq gdl:*gdl-toplevel* "*slime-repl allegro*")
(setq gdl:*inferior-lisp* "*inferior-lisp*")
(global-set-key "\C-x&" '(lambda()(interactive) (switch-to-buffer gdl:*gdl-toplevel*)))
(global-set-key "\C-x*" '(lambda()(interactive) (switch-to-buffer gdl:*inferior-lisp*)))
(global-set-key "\C-xy" '(lambda() (interactive) (other-window -1)))
;;
;; 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))
(require 'cl)
(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)))
......@@ -121,15 +121,6 @@ If you specify :part-symbol-supplied, do not specify :instance-supplied."))
:computed-slots
(
#+nil
(definition `(define-object ,(the part-full-symbol) (,@(the mixins-list))
,@(mapcan #'(lambda(section)
(list (the-object section category)
(the-object section bindings)))
(list-elements (the sections)))))
(main-sheet-body
(with-cl-who-string ()
......@@ -303,23 +294,7 @@ If you specify :part-symbol-supplied, do not specify :instance-supplied."))
:functions
(
#+nil
(write-html-sheet
nil
(html (:html
(:head
(the default-header-content)
(:title "Documentation for "
(:princ (string (the :part-full-symbol)))
" in Package "
(:princ
(string (package-name (the :part-package))))))
(:body (when *developing?* (html (:p (the (write-development-links)))))
;;(when *adsense?* (html (:p (:princ *adsense-code*))))
(when (the :return-object) (html (:p (the (:write-back-link :display-string "<-Back")))))
(the (:write-documentation))
(when (the :return-object) (html (:p (the (:write-back-link :display-string "<-Back")))))
(:p (the :write-footer))))))
(write-documentation
nil
......@@ -454,12 +429,9 @@ If you specify :part-symbol-supplied, do not specify :instance-supplied."))
(or (search "(generate-sample-drawing" (the example-code))
(search "(with-format (pdf" (the example-code))))
(let ((image-file (the image-file)) (image-format :png)
(pdf-file (merge-pathnames "example.pdf"
#+allegro (sys:temporary-directory)
#-allegro sys::*temp-directory*))
(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
......@@ -497,7 +469,7 @@ If you specify :part-symbol-supplied, do not specify :instance-supplied."))
(delete-file image-file)
(delete-file lisp-file)
(delete-file (make-pathname :name (pathname-name lisp-file)
:type gdl::*fasl-default-type*
:type glisp:*fasl-extension*
:directory (pathname-directory lisp-file)
:device (pathname-device lisp-file))))))))
......
......@@ -4,11 +4,12 @@
:author
"Genworks and Dave Cooper unless otherwise indicated"
:license "AGPL unless otherwise indicated" :serial t
:version "2011101700" :components
:version "2011102800"
:components
((:file "common/package")
(:file "common/genworks")
(:file "common/start-gdl")
(:file "prereqs/source/parameters")
(:file "common/genworks")
(:file "common/start-gdl")
(:file "prereqs/source/parameters")
(:file "prereqs/source/metaclasses")
(:file "prereqs/source/utilities")
(:file "expanders/source/inputs")
......@@ -28,8 +29,12 @@
(:file "rest/source/base-rule-object")
(:file "rest/source/bodies")
(:file "rest/source/ignore-errors-with-backtrace")
(:file "rest/source/init")
(:file "rest/source/make-part")
(:file "rest/source/null-part")
(:file "rest/source/quantification")
(:file "rest/source/sequence")
(:file "rest/source/init")))
(:file "tests/source/package")
(:file "tests/source/andrew")
(:file "tests/source/hello")
(:file "tests/source/minimal")))
\ No newline at end of file
......@@ -21,6 +21,7 @@
(in-package :gdl)
(defmacro defaulting (form &optional default)
"Lisp object. Returns a default value if the reference-chain is not handled.
......
......@@ -30,7 +30,7 @@
:documentation (:description "Vanilla-Mixin is automatically inherited by every object
created in GDL. It provides basic messages which are common to all GDL objects defined
with the define-object macro, unless <tt>:no-vanilla-mixin t</tt> is specified at the toplevel
with the define-object macro, unless <tt>:no-vanilla-mixin t</tt> is specifqqied at the toplevel
of the define-object form.")
:input-slots
......@@ -577,13 +577,16 @@ by the update."
(methods (the (:message-list :category :functions)))
(immune-messages (list :$$ta2 :$$ta2-object
:$$tatu :$$tatu-object))
;;
;; FLAG -- get rid of special-casing and ignore-errors for root-object-object.
;;
(root-object-object-vt
(when (defaulting (the root-object-object))
(when (ignore-errors (the root-object-object))
(mapcar #'(lambda(path)
(when (consp (rest path))
(cons (append (first path) (list :root-object-object))
(rest path))))
(gdl-acc::%version-tree% (defaulting (the root-object-object)))))))
(gdl-acc::%version-tree% (ignore-errors (the root-object-object)))))))
(let ((cached-messages
(set-difference all-messages (append methods immune-messages))))
......
......@@ -13,8 +13,8 @@
#:match-regexp
#:patches-dir
#:process-run-function
#:replace-regexp
#:remote-host
#:replace-regexp
#:socket-bytes-written
#:with-timeout-sym
......@@ -76,13 +76,15 @@
#-allegro #'acl-compat.mp:process-run-function
name-or-options preset-function args))
(defun replace-regexp (string regexp to-string)
(cl-ppcre:regex-replace-all regexp string to-string))
(defun remote-host (socket)
#+allegro (socket:remote-host socket)
#-allegro (acl-compat.socket:remote-host socket))
(defun replace-regexp (string regexp to-string)
(cl-ppcre:regex-replace-all regexp string to-string))
(defun socket-bytes-written (socket)
#-allegro (declare (ignore socket))
#+allegro (excl::socket-bytes-written socket)
......
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