Commit 92fd2672 authored by Dave Cooper's avatar Dave Cooper
Browse files

Added CLISP support, fixed remote-object for non-Allegro platforms.

parent b1d64928
......@@ -36,7 +36,8 @@
(butlast (pathname-directory gdl-base-home)))
:defaults gdl-base-home)))
#-(or allegro lispworks sbcl ccl abcl ecl) (error "Need implementation for command-line-arguments in currently running lisp.~%")
#-(or allegro lispworks sbcl ccl abcl ecl clisp)
(error "Need implementation for command-line-arguments in currently running lisp.~%")
(defun basic-command-line-arguments ()
#+allegro (sys:command-line-arguments :application nil)
#+lispworks system:*line-arguments-list*
......@@ -44,29 +45,34 @@
#+ccl (ccl::command-line-arguments)
#+abcl extensions:*command-line-argument-list*
#+ecl (loop for n from 0 below (si:argc) collect (si:argv n))
#+clisp (coerce (ext:argv) 'list)
)
#-(or allegro lispworks cmu sbcl ccl abcl ecl)
#-(or allegro lispworks cmu sbcl ccl abcl ecl clisp)
(error "Need implementation for executable-homedir-pathname for currently running lisp.~%")
(defun executable-homedir-pathname ()
#+allegro (translate-logical-pathname "sys:")
#+sbcl (make-pathname :name nil :type nil :defaults sb-ext:*core-pathname*)
#+(or lispworks ccl ecl) (make-pathname :name nil :type nil :defaults (first (glisp:basic-command-line-arguments)))
#+abcl (warn "Don't know how to get executable-homedir-pathname on ABCL! Please find out.~%"))
#+(or lispworks ccl ecl clisp) (make-pathname :name nil :type nil :defaults (first (glisp:basic-command-line-arguments)))
#+abcl
(warn "Don't know how to get executable-homedir-pathname on ~a! Please find out.~%"
(lisp-implementation-type)))
(defparameter *gdl-program-home* #-abcl (glisp:executable-homedir-pathname)
#+abcl (progn (warn "Don't know how to get executable-homedir-pathname on ABCL! Please find out.~%")
nil))
#+abcl
(progn (warn "Don't know how to get executable-homedir-pathname on ~a! Please find out.~%"
(lisp-implementation-type)) nil))
(defparameter *gdl-home* #-abcl
(make-pathname :name nil
:type nil
:type nil
:directory (butlast (pathname-directory *gdl-program-home*))
:defaults *gdl-program-home*)
#+abcl (progn (warn "Don't know how to get *gdl-home* on ABCL! Please find out.~%")
nil))
#+abcl
(progn (warn "Don't know how to get *gdl-home* on ABCL! Please find out.~%")
nil))
;;
......@@ -75,33 +81,36 @@
;; redefinition warnings until we get a better handle on
;; things.
;;
#-(or allegro lispworks sbcl)
#-(or allegro lispworks sbcl clisp)
(warn "Need parameter for redefinition warnings for currently running lisp.~%")
(let (#+(or allegro lispworks)
(let (#+(or allegro lispworks clisp)
(original-redefinition-warnings
#+allegro excl:*redefinition-warnings*
#+lispworks lw:*redefinition-action*))
#+lispworks lw:*redefinition-action*
#+clisp custom:*suppress-check-redefinition*))
(defun begin-redefinitions-ok ()
#+sbcl (declare (sb-ext:muffle-conditions sb-ext:compiler-note))
#+(or allegro lispworks)
#+(or allegro lispworks clisp)
(setq #+allegro excl:*redefinition-warnings*
#+lispworks lw:*redefinition-action* nil))
#+lispworks lw:*redefinition-action*
#+clisp custom:*suppress-check-redefinition* nil))
(defun end-redefinitions-ok ()
#+sbcl (declare (sb-ext:unmuffle-conditions sb-ext:compiler-note))
#+(or allegro lispworks)
#+(or allegro lispworks clisp)
(setq #+allegro excl:*redefinition-warnings*
#+lispworks lw:*redefinition-action*
#+clisp custom:*suppress-check-redefinition*
original-redefinition-warnings)))
#-(or allegro lispworks cmu sbcl ccl abcl ecl)
#-(or allegro lispworks cmu sbcl ccl abcl ecl clisp)
(error "Need implementation for current-directory for currently running lisp.~%")
(defun current-directory ()
#+allegro (excl:current-directory)
#+lispworks (sys:current-directory)
#+(or sbcl abcl ecl) *default-pathname-defaults*
#+(or sbcl abcl ecl clisp) *default-pathname-defaults*
#+cmu (second (multiple-value-list (unix:unix-current-directory)))
#+ccl (ccl:current-directory)
......@@ -115,7 +124,7 @@
,@(when doc (list doc))))
#-(or allegro lispworks sbcl ccl abcl ecl)
#-(or allegro lispworks sbcl ccl abcl ecl clisp)
(error "Need implementation for class-direct-superclasses for currently running lisp.~%")
(defun direct-superclasses (class)
"Return a list of the direct superclasses."
......@@ -123,7 +132,7 @@
#+lispworks hcl:class-direct-superclasses
#+sbcl sb-mop:class-direct-superclasses
#+ccl ccl:class-direct-superclasses
#+ecl clos:class-direct-superclasses class))
#+(or ecl clisp) clos:class-direct-superclasses class))
(defun direct-superclass-names (class)
......@@ -135,32 +144,33 @@
(declare (ignore edition))
(format t banner))
#-(or allegro lispworks cmu sbcl ccl abcl ecl)
#-(or allegro lispworks cmu sbcl ccl abcl ecl clisp)
(error "Need implementation for eql-specializer for currently running lisp.~%")
(defun eql-specializer (attr-sym)
#+(or allegro abcl) (mop:intern-eql-specializer attr-sym)
#+(or lispworks cmu) (list 'eql attr-sym)
#+sbcl (sb-mop:intern-eql-specializer attr-sym)
#+ccl (ccl:intern-eql-specializer attr-sym)
#+ecl (clos:intern-eql-specializer attr-sym)
#+(or ecl clisp) (clos:intern-eql-specializer attr-sym)
)
(defun find-feature (feature) (find feature *features*))
#-(or allegro lispworks sbcl ccl abcl ecl) (error "Need implementation of featurep for currently running lisp.~%")
#-(or allegro lispworks sbcl ccl abcl ecl clisp)
(error "Need implementation of featurep for currently running lisp.~%")
(defun featurep (x)
(#+allegro excl:featurep #+lispworks system:featurep #+sbcl sb-int:featurep
#+ccl asdf::featurep #+abcl extensions:featurep
#+ecl find-feature x))
#+ecl find-feature
#+clisp ext:featurep x))
(defun gl-class-name (class)
"Return the class name."
(#-cmu class-name #+cmu mop:class-name class))
#-(or allegro lispworks cmu sbcl ccl abcl ecl)
#-(or allegro lispworks cmu sbcl ccl abcl ecl clisp)
(error "Need implementation for method-specializers for currently running lisp.~%")
(defun gl-method-specializers (method)
"Return a list of method specializers for the given method."
......@@ -169,7 +179,7 @@
#+cmu pcl:method-specializers
#+sbcl sb-mop:method-specializers
#+ccl ccl:method-specializers
#+ecl clos:method-specializers
#+(or ecl clisp) clos:method-specializers
method))
......@@ -203,7 +213,7 @@
#-allegro (make-hash-table)))
#-(or allegro lispworks sbcl ccl abcl ecl)
#-(or allegro lispworks sbcl ccl abcl ecl clisp)
(error "Need implementation for make-weak-hash-table for currently running lisp.~%")
#+ecl (warn "Need weak-hash-tables for ECL, or we will be running out of memory in web apps.~%")
(defun make-weak-hash-table (&rest args)
......@@ -212,6 +222,8 @@
#+allegro :values #+allegro :weak
#+lispworks :weak-kind #+lispworks t
#+(or sbcl abcl) :weakness #+(or sbcl abcl) :key-and-value
#+clisp :weak #+clisp :key-and-value
#+ccl :weak #+ccl :key #+ccl :test #+ccl #'eq
args))
(defun set-default-float-format ()
......@@ -246,6 +258,7 @@
#+lispworks dspec:*source-pathname*
#+sbcl (error "need source-pathname in sbcl~%")
#+ccl (error "need source-pathname in ccl~%")
#+clisp (error "need source-pathname in ccl~%")
#+abcl (extensions:source-pathname)
)
......@@ -272,13 +285,11 @@
(:case-sensitive-lower string)))
(defmacro w-o-interrupts (&body body)
(format t "~&NOTE: Without-interrupts is deprecated in multiprocessing Lisp - replace usage with something else in glisp:w-o-interrupts.~%")
#-(or allegro lispworks cmu sbcl ccl abcl) (error "Need implementation for without-interrupts for currently running lisp.~%")
`(#+allegro excl:without-interrupts
#+lispworks progn
#+ccl progn
#+abcl progn
#+ecl progn
(format t "~&NOTE: from glisp:w-o-interrupts: without-interrupts is deprecated in multiprocessing Lisp - using progn - replace usage with something else e.g. process-locks.~%")
#-(or allegro lispworks cmu sbcl ccl abcl clisp)
(error "Need implementation for without-interrupts for currently running lisp.~%")
`(#+allegro progn ;; excl:without-interrupts
#+(or lispworks ccl abcl ecl clisp) progn
#+cmu system:without-interrupts
#+sbcl sb-sys:without-interrupts
,@body))
......@@ -328,11 +339,6 @@
#+lispworks compiler:*produce-xref-info*
t))
#-(or allegro lispworks sbcl ccl abcl ecl) (error "need with-definition-unit for currently running lisp.~%")
(defmacro with-definition-unit (&body body)
#+(or allegro abcl ecl) `(with-compilation-unit () ,@body)
#+(or lispworks sbcl ccl) `(progn ,@body))
(defmacro without-package-variance-warnings (&body body)
`(eval-when (:compile-toplevel :load-toplevel :execute)
......
......@@ -22,7 +22,7 @@
(in-package :common-lisp-user)
(eval-when (:compile-toplevel :load-toplevel :execute)
#-(or allegro lispworks sbcl ccl abcl) (error "
#-(or allegro lispworks sbcl ccl abcl clisp) (error "
D'oh! GenDL is not yet supported on ~a. If you would like to try porting it, start with this file,
gdl/base/common/genworks.lisp.
......@@ -324,6 +324,7 @@ If you are interested in this effort we would love to hear from you at open-sour
#:gc-full
#:get-backtrace
#:initialize-multiprocessing
#:local-port
#:match-regexp
#:patches-dir
#:process-run-function
......@@ -333,6 +334,7 @@ If you are interested in this effort we would love to hear from you at open-sour
#:slot-definition-name
#:socket-bytes-written
#:split-regexp
#:with-heuristic-case-mode
#:with-timeout-sym
;;
......
......@@ -90,10 +90,12 @@
(when (and *compile-for-dgdl?* (not (eql attr-sym 'gdl-acc::type)))
`(defmethod ,(glisp:intern (symbol-name attr-sym) :gdl-inputs) ((,parent-arg gdl-remote)
,part-arg
(,self-arg gdl-basis))
(the-object ,parent-arg (fetch-input ,(make-keyword attr-sym) ,part-arg ,self-arg))))
`(unless (find-method (symbol-function ',(glisp:intern attr-sym :gdl-inputs))
nil (list (find-class 'gdl-remote) t (find-class 'gdl-basis)) nil)
(defmethod ,(glisp:intern attr-sym :gdl-inputs) ((,parent-arg gdl-remote)
,part-arg
(,self-arg gdl-basis))
(the-object ,parent-arg (fetch-input ,(make-keyword attr-sym) ,part-arg ,self-arg)))))
`(defmethod ,(glisp:intern (symbol-name attr-sym) :gdl-slots) ((self ,name) &rest ,args-arg)
(declare (ignore ,args-arg))
......
......@@ -40,7 +40,7 @@ a symbol, this is the name of the slot and there will be no default value.\"
`(,(glisp:intern (symbol-name slot) :gdl-acc) :initarg ,(make-keyword slot))
`(,(glisp:intern (symbol-name (first slot)) :gdl-acc) :initform ,(second slot)
:initarg ,(make-keyword (first slot))
:documentation ,(third slot))))
:documentation ,(or (third slot) ""))))
slots) (:metaclass gdl-format-class))
(let ((,class (find-class ',name)))
(let ((,old-format-functions (format-functions ,class))
......@@ -174,6 +174,10 @@ Removing output function: ~a for view of format: ~a on object definition: ~s wit
(the (send-output (:apply (cons ,(make-keyword attr-sym)
(cons *%format%* ,args-arg))))))))))
(eval-when (:compile-toplevel :load-toplevel :execute) (glisp:end-redefinitions-ok))
;;
;; FLAG -- implement this documentation properly and according to ANSI stanards.
;;
#-clisp
,(when (and *compile-documentation-database?* attr-remarks)
`(when *load-documentation-database?* (setf (documentation ,method nil) ,attr-remarks))))))))
......
......@@ -254,41 +254,41 @@ Defaults to nil (i.e. we assume we are loading into a clean system and need all
(asdf-system-list
(let ((binaries (the compile-and-load)))
(append `(asdf:defsystem ,(read-from-string (format nil "#:~a" (pathname-name (the asd-file))))
: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 ,(string-append
(replace-substring (iso-8601-date (get-universal-time)) "-" "") "00")
:depends-on ,(the asdf-depends-on)
;;
;; FLAG -- maybe can get rid of binaries and need to call (the compile-and-load)
;;
:components ,(mapcar #'(lambda(binary source)
(let ((binary (make-pathname :directory (remove "bin"
(pathname-directory binary)
:test #'string-equal)
:defaults binary)))
(let ((namestring (replace-substring
(namestring
(make-pathname :name (pathname-name binary)
:type nil ;;(pathname-type source)
:defaults
(enough-namestring binary (the ppathname))))
"\\" "/")))
: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 ,(string-append
(replace-substring (iso-8601-date (get-universal-time)) "-" "") "00")
:depends-on ,(the asdf-depends-on)
;;
;; FLAG -- maybe can get rid of binaries and need to call (the compile-and-load)
;;
:components ,(mapcar #'(lambda(binary source)
(let ((binary (make-pathname :directory (remove "bin"
(pathname-directory binary)
:test #'string-equal)
:defaults binary)))
(let ((namestring (replace-substring
(namestring
(make-pathname :name (pathname-name binary)
:type nil ;;(pathname-type source)
:defaults
(enough-namestring binary (the ppathname))))
"\\" "/")))
(list (if (string-equal (pathname-type source) "lisp")
:file
(make-keyword (pathname-type source)))
namestring)
(list (if (string-equal (pathname-type source) "lisp")
:file
(make-keyword (pathname-type source)))
namestring)
#+nil
(list :file namestring
:pathname
(merge-pathnames namestring "")))))
#+nil
(list :file namestring
:pathname
(merge-pathnames namestring "")))))
binaries (the source-file-list)))))
binaries (the source-file-list)))))
:uncached)
......@@ -331,7 +331,8 @@ Defaults to nil (i.e. we assume we are loading into a clean system and need all
:if-exists :supersede
:if-does-not-exist :create)
(let ((*print-right-margin* 70)
(*print-case* :downcase))
(*print-case* :downcase)
(*package* (or (find-package :asdf-user) (find-package :asdf))))
(pprint (the asdf-system-list) out)
(when (the additional-asd-code)
(format out "~%~%")
......
......@@ -21,15 +21,14 @@
(in-package :com.genworks.lisp)
(defparameter *fasl-extension*
#+allegro excl:*fasl-default-type*
#+lispworks compiler:*fasl-extension-string*
#+sbcl sb-fasl:*fasl-file-type*
#+ccl (namestring ccl:*.fasl-pathname*)
#+abcl "abcl"
#-(or allegro lispworks sbcl ccl abcl) (error "Need fasl extension string for the currently running lisp.~%"))
#+clisp "fas"
#-(or allegro lispworks sbcl ccl abcl clisp) (error "Need fasl extension string for the currently running lisp.~%"))
#-(or allegro lispworks sbcl ccl)
......@@ -101,7 +100,14 @@ and \"..\" entries."
:directories t)
#+abcl
(directory (merge-pathnames *wild-entry* pathspec)
:resolve-symlinks nil))
:resolve-symlinks nil)
#+clisp
(mapcar 'first
(nconc (directory (merge-pathnames *wild-entry* directory)
:full t)
(directory (merge-pathnames *wild-relative* directory)
:full t))))
(defun file-directory-p (file)
......
(in-package :com.genworks.lisp)
#-(or allegro lispworks sbcl ccl abcl) (error "Need implementation for get-pid for currently running lisp~%")
#-(or allegro lispworks sbcl ccl abcl clisp) (error "Need implementation for get-pid for currently running lisp~%")
(defun get-pid ()
#+allegro (excl.osi:getpid)
#+lispworks (multiple-value-bind (status pid)
......@@ -48,9 +48,24 @@
:collecting (code-char b) :into result
:finally (return
(parse-integer (coerce result 'string)))))
(t () 0))
(t () 0)))
;;
;; FLAG Lifted from swank-clisp.lisp:
;;
#+clisp
(let ((getpid (or (find-symbol "PROCESS-ID" :system)
;; old name prior to 2005-03-01, clisp <= 2.33.2
(find-symbol "PROGRAM-ID" :system)
#+win32 ; integrated into the above since 2005-02-24
(and (find-package :win32) ; optional modules/win32
(find-symbol "GetCurrentProcessId" :win32)))))
(defun getpid () ; a required interface
(cond
(getpid (funcall getpid))
#+win32 ((ext:getenv "PID")) ; where does that come from?
(t -1))))
)
(defun run-gs (command)
......
......@@ -114,7 +114,7 @@ meaning the crosshairs will remain the same size regardless of zoom state."
(define-lens (pdf simple-vector)()
(define-lens (pdf vector)()
:output-functions
((cad-output
()
......
......@@ -483,7 +483,7 @@
(the color-hex)))))))))))
(define-lens (raphael simple-vector)()
(define-lens (raphael vector)()
:output-functions
((cad-output
()
......
......@@ -4,11 +4,14 @@
:author
"Genworks and Dave Cooper unless otherwise indicated"
:license "AGPL unless otherwise indicated" :serial t
:version "2012101100" :depends-on
:version "2012101100"
:depends-on
(:gdl-base :gdl-cl-lite :aserve :cl-pdf :cl-who
:cl-ppcre #-allegro :cl-base64 #-allegro :babel
:trivial-backtrace
:cl-html-parse)
:components
((:file "source/genworks")
(:file "source/defparameters")
......
......@@ -21,7 +21,10 @@
(in-package :gwl)
;;
;; This is now defined up-front in gdl/base/prereqs/source/utilities.lisp.
;;
#+nil
(defclass gdl-remote () ()
(:metaclass gdl-class))
......@@ -65,6 +65,11 @@ the \"current\" error."
)
(defun local-port (socket)
(#+allegro
socket:local-port
#-allegro acl-compat.socket:local-port socket))
(defun match-regexp (string-or-regexp string-to-match
&key newlines-special case-fold return
(start 0) end shortest)
......@@ -257,6 +262,11 @@ please find implementation for the currently running lisp.~%")
(defun split-regexp (regexp string)
(cl-ppcre:split regexp string))
(defmacro with-heuristic-case-mode ((&rest args) &body body)
(declare (ignore args))
#-allegro `(let ((*print-case* :downcase)) ,@body)
#+allegro `(progn ,@body))
(defun with-timeout-sym ()
"Returns the appropriate symbol for with-timeout, for substitution within macros."
#+allegro 'sys:with-timeout
......
......@@ -49,32 +49,33 @@
(gdl::*notify-cons* (decode-from-http (getf args-list :notify-cons)))
(part-name (getf args-list :part-name))
(args (getf args-list :args)))
(with-http-response (req ent)
(with-http-body (req ent)
(let ((value (if object (multiple-value-bind (value error)
(ignore-errors
(apply (symbol-function (glisp:intern message :gdl-inputs))
object (glisp:intern part-name :gdl-acc) child args))
(if (typep error 'error)
(let ((error-string
(glisp:replace-regexp
(format nil "~a" error) "\\n" " ")))
(cond ((or (search "could not handle"
error-string)
#+nil
(search "which is the root"
error-string)
(search "instances could handle"
error-string))
'gdl-rule:%not-handled%)
(t (when *debug?*
(format t "Throwing error on fetch-input server because gwl::*debug?* is set to non-nil~%")
(error error))
(list :error (format nil "~a" error)))))
value))
(list :error :no-such-object (getf args-list :remote-id)))))
(let ((encoded-value (base64-encode-safe (format nil "~s" (encode-for-http value)))))
(html (format *html-stream* encoded-value))))))))))))
(glisp:with-heuristic-case-mode ()
(with-http-response (req ent)
(with-http-body (req ent)
(let ((value (if object (multiple-value-bind (value error)
(ignore-errors
(apply (symbol-function (glisp:intern message :gdl-inputs))
object (glisp:intern part-name :gdl-acc) child args))
(if (typep error 'error)
(let ((error-string
(glisp:replace-regexp
(format nil "~a" error) "\\n" " ")))
(cond ((or (search "could not handle"
error-string)
#+nil
(search "which is the root"
error-string)
(search "instances could handle"
error-string))
'gdl-rule:%not-handled%)
(t (when *debug?*
(format t "Throwing error on fetch-input server because gwl::*debug?* is set to non-nil~%")
(error error))
(list :error (format nil "~a" error)))))
value))
(list :error :no-such-object (getf args-list :remote-id)))))
(let ((encoded-value (base64-encode-safe (format nil "~s" (encode-for-http value)))))
(html (format *html-stream* encoded-value)))))))))))))
(publish :path "/unbind-slots"
......@@ -208,8 +209,8 @@
(the-object object (set-slot! :%name% name :warn-on-non-toplevel? nil))
(the-object object (set-slot! :remote-id new-id :remember? nil :warn-on-non-toplevel? nil))
(the-object object (set-slot! :%index% index :warn-on-non-toplevel? nil))
(setf (slot-value object 'gdl-acc::%parent%)
(list (evaluate-object (first parent-form) (rest parent-form)) nil t))
(setf (slot-value object 'gdl-acc::%parent%)
(list (evaluate-object (first parent-form) (rest parent-form)) nil t))
(setf (gethash new-id *remote-objects-hash*) object)
(format t "~&~%Created new remote object with ID ~s and arglist:
~s~%~%"
......
......@@ -244,9 +244,9 @@
:type (format nil "~s" (the-object item type))
:root-path (the-object item root-path)
:host :unknown
:port (slot-value (slot-value (symbol-value (read-from-string "net.aserve:*wserver*"))
(read-from-string "net.aserve::socket")) #+allegro 'socket:local-port
#-allegro 'acl-compat.socket::port)))
:port (glisp:local-port
(slot-value (symbol-value (read-from-string "net.aserve:*wserver*"))
(read-from-string "net.aserve::socket")))))
(defmethod print-object ((object remote-object) stream)
......
(in-package :gwl)
(defmacro with-error-handling ((&key (error? nil)
(timeout 2)
(timeout-body
`(warn "Timed Out after ~a Seconds" ,timeout)))
&body body)
"[Macro]. Wraps the <b>body</b> of code with error-trapping and system timeout.
(#+allegro
excl:without-redefinition-warnings