Commit 44b0277b authored by Teodor Gelu Chiciudean's avatar Teodor Gelu Chiciudean
Browse files

Merge remote-tracking branch 'upstream/master'

* upstream/master:
  fixed png image output in yadd
  added startup scripts for initial combo of editor and CL -- more combos need to be added
  Improving the load experience on Lispworks. Working with Slime on LispWorks.
  try to make images work in yadd
parents 04658cd4 1f4c642a
#!/bin/bash
cd `dirname "$0"`
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"))
;;
;; 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 ()
......@@ -221,7 +212,7 @@ If you specify :part-symbol-supplied, do not specify :instance-supplied."))
(princ (the example-code) out))
(let (*redefinition-warnings*) (load (compile-file (the lisp-file))))) :uncached)
(image-file (merge-pathnames (funcall gdl::*make-temp-file-name-func*) #p"*.png"))
(image-file (glisp:temporary-file :extension "png"))
(image-url (format nil "/images/~a" (make-pathname :name (pathname-name (the image-file))
:type (pathname-type (the image-file)))))
......@@ -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
......@@ -478,14 +450,7 @@ If you specify :part-symbol-supplied, do not specify :instance-supplied."))
pdf-file)))
(let ((return-value
(#+allegro
run-shell-command
#+lispworks system:call-system
#+cmu asdf:run-shell-command
command
#+allegro :show-window
#+allegro :hide)))
(glisp:run-shell-command command :show-window? nil)))
(with-http-response (req ent)
(setf (reply-header-slot-value req :cache-control) "no-cache")
(setf (reply-header-slot-value req :pragma) "no-cache")
......@@ -504,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))))))))
......@@ -832,11 +797,9 @@ If you specify :part-symbol-supplied, do not specify :instance-supplied."))
(:body (the (write-back-link :display-string "<-Back"))
(:h2 (:center "Example in VRML format"))
(:p (let ((vrml-url (string-append "/vrml/"
(file-namestring
(make-pathname
:name
(pathname-name
(funcall gdl::*make-temp-file-name-func*)) :type "wrl")))))
(namestring
(glisp:temporary-file :extension "wrl")))))
(publish :path vrml-url
:content-type "x-world/x-vrml"
:function #'(lambda(req ent)
......
......@@ -54,9 +54,8 @@ The javascript loaded is jquery."
((:script :type "text/javascript"
:src "/static/3rdpty/jquery/js/jquery.quicksearch.js"))))
(footer (let* ((updater (make-object 'gwl::gdl-updater))
(version (the-object updater gdl-version))
(patch (the-object updater gdl-patchlevel)))
(footer (let* ((version "1581")
(patch 9))
(with-cl-who-string ()
((:p :class "copyrightFooter")
"Copyright © "
......@@ -86,9 +85,8 @@ The javascript loaded is jquery."
(write-footer
()
(let ((*stream* (or *html-stream* *stream*)))
(let* ((updater (make-object 'gwl::gdl-updater))
(version (the-object updater gdl-version))
(patch (the-object updater gdl-patchlevel)))
(let* ((version "1581")
(patch 9))
(with-cl-who()
((:p :class "copyrightFooter")
"Copyright © "
......
......@@ -288,8 +288,7 @@
#+lispworks compiler:*produce-xref-info*
t))
(defun display-startup-banner (edition banner banner2)
(defun display-startup-banner (edition banner)
(ecase edition
(:open-source
#-lispworks (format t banner)
#+lispworks (capi:prompt-with-message banner2))))
(:open-source (format t banner))))
......@@ -74,22 +74,8 @@
http://www.gnu.org/licenses/
"
"
Copyright 2002-2011 Genworks International and Genworks BV
This is the General-purpose Declarative Language (GDL).
This program 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 program 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 the source code for this program. If not, see:
"))
http://www.gnu.org/licenses/
"
))
(pushnew #'startup-banner *gdl-init-functions*)
......
......@@ -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))))
......
(:gdl-base :cl-typesetting)
(:cl-lite :cl-typesetting)
......@@ -4,69 +4,6 @@
(in-package :pdf)
(defmethod write-object ((obj indirect-object) &optional root-level)
(if root-level
(progn
(vector-push-extend (format nil "~10,'0d ~5,'0d n "
;;FLAG -- DJC added conditional for allegro to handle aserve streams
#+allegro (if (typep *pdf-stream* 'excl::hiper-socket-stream)
(progn (force-output *pdf-stream*)
(excl::socket-bytes-written *pdf-stream*))
(file-position *pdf-stream*))
#+lispworks (if (typep *pdf-stream* 'acl-compat.socket::bidirectional-binary-socket-stream)
(progn (force-output *pdf-stream*)
(acl-compat.socket::stream-file-position *pdf-stream*))
(file-position *pdf-stream*))
#-(or allegro lispworks) (file-position *pdf-stream*)
(gen-number obj))
*xrefs*)
(format *pdf-stream* "~d ~d obj~%" (obj-number obj)(gen-number obj))
(when (content obj)(write-object (content obj)))
(write-string "endobj" *pdf-stream*)
(write-char #\Newline *pdf-stream*))
(format *pdf-stream* "~d ~d R" (obj-number obj)(gen-number obj))))
(defmethod write-document ((s stream) &optional (document *document*))
(let ((*xrefs* (make-array 10 :adjustable t :fill-pointer 0))
startxref
(*pdf-stream* s))
;;(with-standard-io-syntax
#+lispworks (if (typep s 'acl-compat.socket::bidirectional-binary-socket-stream)
(setf acl-compat.socket::*socket-bytes-written* 0))
(let ((*read-default-float-format* 'double-float))
(process-outlines document)
(vector-push-extend "0000000000 65535 f " *xrefs*)
(write-line +pdf-header+ *pdf-stream*)
(loop for obj across (objects document)
for first = t then nil
if obj do (write-object obj t)
else do (unless first (vector-push-extend "0000000000 00001 f " *xrefs*)))
;;(setf startxref (file-position s))
(setf startxref #+allegro (if (typep s 'excl::hiper-socket-stream)
(progn (force-output s)
(excl::socket-bytes-written s))
(file-position s))
#+lispworks (if (typep s 'acl-compat.socket::bidirectional-binary-socket-stream)
(progn (force-output s)
(acl-compat.socket::stream-file-position s))
(file-position s))
#-(or allegro lispworks) (file-position s))
(format *pdf-stream* "xref~%0 ~d~%" (length *xrefs*))
(loop for xref across *xrefs*
do (write-line xref s))
(format s "trailer~%<< /Size ~d~%/Root " (length *xrefs*));(1- (length (objects document))))
(write-object (catalog document))
(when (docinfo document)
(format s " /Info ")
(write-object (docinfo document)))
(format s "~%>>~%startxref~%~d~%%%EOF~%" startxref))))
(defmacro with-page ((&rest args) &body body)
`(let* ((*page* (make-instance 'page ,@args)))
......
......@@ -5,12 +5,13 @@
(:use :common-lisp)
(:export #:get-pid
#:run-gs
#:run-shell-command
#:set-gs-path
)))
(defun featurep (x)
#+allegro (excl:featurep x)
#+lispworks (system:featurep x)
......@@ -20,6 +21,38 @@
(defun get-pid ()
#+allegro (excl.osi:getpid)
#+lispworks (multiple-value-bind (status pid)
(system:call-system-showing-output "echo $PPID"
:show-cmd nil :output-stream nil)
(declare (ignore status))
(read-from-string pid))
#-(or allegro lispworks)
(error "Need implementation for get-pid for currently running lisp~%"))
(defun run-gs (command)
"Shell out a ghostscript command and handle errors."
#-allegro (let ((result (asdf-utilities:run-shell-command command)))
(unless (zerop result) (error "Ghostscript threw error")))
#+allegro
(multiple-value-bind (output error return)
(excl.osi:command-output command)
(unless (zerop return) (error "Ghostscript command threw error. Result was:
output: ~a
error: ~a
return: ~a"
output error return))))
(defun run-shell-command (command &rest args)
;;
;; FLAG -- add specific keyword args e.g. for hide-window?
;;
(asdf-utilities:run-shell-command command))
(defun set-gs-path (&optional gs-path)
(if (featurep :mswindows)
(let (found-path)
......@@ -51,29 +84,4 @@
(when (and (stringp gdl:*gs-path*) (string-equal gdl:*gs-path* "gs")) (warn "Gnu Ghostscript (\"gs\") was not found
in either /usr/local/bin or /usr/bin -- we assume it is elsewhere in your execution path
so we are setting it simply to \"gs\". If Gnu Ghostscript is not installed on your Unix/Linux
system, please contact Genworks for assistance in installing it.")))))
(defun get-pid ()
#+allegro (excl.osi:getpid)
#+lispworks (multiple-value-bind (status pid)
(system:call-system-showing-output "echo $PPID"
:show-cmd nil :output-stream nil)
(declare (ignore status))
(read-from-string pid))
#-(or allegro lispworks)
(error "Need implementation for get-pid for currently running lisp~%"))
(defun run-gs (command)
"Shell out a ghostscript command and handle errors."
#-allegro (let ((result (asdf-utilities:run-shell-command command)))
(unless (zerop result) (error "Ghostscript threw error")))
#+allegro
(multiple-value-bind (output error return)
(excl.osi:command-output command)
(unless (zerop return) (error "Ghostscript command threw error. Result was:
output: ~a
error: ~a
return: ~a"
output error return))))
system, please contact Genworks for assistance in installing it.")))))
\ No newline at end of file
;;; cl-pdf copyright 2002-2005 Marc Battyani see license.txt for the details
;;; You can reach me at marc.battyani@fractalconcept.com or marc@battyani.net
;;; The homepage of cl-pdf is here: http://www.fractalconcept.com/asp/html/cl-pdf.html
(in-package :pdf)
(defmethod write-object ((obj indirect-object) &optional root-level)
(if root-level
(progn
(vector-push-extend (format nil "~10,'0d ~5,'0d n "
;;FLAG -- DJC added conditional for allegro to handle aserve streams
#+allegro (if (typep *pdf-stream* 'excl::hiper-socket-stream)
(progn (force-output *pdf-stream*)
(excl::socket-bytes-written *pdf-stream*))
(file-position *pdf-stream*))
#+lispworks (if (typep *pdf-stream* 'acl-compat.socket::bidirectional-binary-socket-stream)
(progn (force-output *pdf-stream*)
(acl-compat.socket::stream-file-position *pdf-stream*))
(file-position *pdf-stream*))
#-(or allegro lispworks) (file-position *pdf-stream*)
(gen-number obj))
*xrefs*)
(format *pdf-stream* "~d ~d obj~%" (obj-number obj)(gen-number obj))
(when (content obj)(write-object (content obj)))
(write-string "endobj" *pdf-stream*)
(write-char #\Newline *pdf-stream*))
(format *pdf-stream* "~d ~d R" (obj-number obj)(gen-number obj))))
(defmethod write-document ((s stream) &optional (document *document*))
(let ((*xrefs* (make-array 10 :adjustable t :fill-pointer 0))
startxref
(*pdf-stream* s))
;;(with-standard-io-syntax
#+lispworks (if (typep s 'acl-compat.socket::bidirectional-binary-socket-stream)
(setf acl-compat.socket::*socket-bytes-written* 0))
(let ((*read-default-float-format* 'double-float))
(process-outlines document)
(vector-push-extend "0000000000 65535 f " *xrefs*)
(write-line +pdf-header+ *pdf-stream*)
(loop for obj across (objects document)
for first = t then nil
if obj do (write-object obj t)
else do (unless first (vector-push-extend "0000000000 00001 f " *xrefs*)))
;;(setf startxref (file-position s))
(setf startxref #+allegro (if (typep s 'excl::hiper-socket-stream)
(progn (force-output s)
(excl::socket-bytes-written s))
(file-position s))
#+lispworks (if (typep s 'acl-compat.socket::bidirectional-binary-socket-stream)
(progn (force-output s)
(acl-compat.socket::stream-file-position s))
(file-position s))
#-(or allegro lispworks) (file-position s))
(format *pdf-stream* "xref~%0 ~d~%" (length *xrefs*))
(loop for xref across *xrefs*
do (write-line xref s))
(format s "trailer~%<< /Size ~d~%/Root " (length *xrefs*));(1- (length (objects document))))
(write-object (catalog document))
(when (docinfo document)
(format s " /Info ")
(write-object (docinfo document)))
(format s "~%>>~%startxref~%~d~%%%EOF~%" startxref))))
......@@ -8,12 +8,13 @@
#:class-slots
#:slot-definition-name
#:gc-full
#:initialize-multiprocessing
#:load-html-parser
#:match-regexp
#:patches-dir
#:process-run-function
#:replace-regexp
#:remote-host
#:replace-regexp
#:socket-bytes-written
#:with-timeout-sym
......@@ -43,6 +44,12 @@
#+allegro (excl:gc t)
#+lispworks (hcl:gc-all))
(defun initialize-multiprocessing ()