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 @@ ...@@ -36,7 +36,8 @@
(butlast (pathname-directory gdl-base-home))) (butlast (pathname-directory gdl-base-home)))
:defaults 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 () (defun basic-command-line-arguments ()
#+allegro (sys:command-line-arguments :application nil) #+allegro (sys:command-line-arguments :application nil)
#+lispworks system:*line-arguments-list* #+lispworks system:*line-arguments-list*
...@@ -44,29 +45,34 @@ ...@@ -44,29 +45,34 @@
#+ccl (ccl::command-line-arguments) #+ccl (ccl::command-line-arguments)
#+abcl extensions:*command-line-argument-list* #+abcl extensions:*command-line-argument-list*
#+ecl (loop for n from 0 below (si:argc) collect (si:argv n)) #+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.~%") (error "Need implementation for executable-homedir-pathname for currently running lisp.~%")
(defun executable-homedir-pathname () (defun executable-homedir-pathname ()
#+allegro (translate-logical-pathname "sys:") #+allegro (translate-logical-pathname "sys:")
#+sbcl (make-pathname :name nil :type nil :defaults sb-ext:*core-pathname*) #+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))) #+(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 ABCL! Please find out.~%")) #+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) (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.~%") #+abcl
nil)) (progn (warn "Don't know how to get executable-homedir-pathname on ~a! Please find out.~%"
(lisp-implementation-type)) nil))
(defparameter *gdl-home* #-abcl (defparameter *gdl-home* #-abcl
(make-pathname :name nil (make-pathname :name nil
:type nil :type nil
:directory (butlast (pathname-directory *gdl-program-home*)) :directory (butlast (pathname-directory *gdl-program-home*))
:defaults *gdl-program-home*) :defaults *gdl-program-home*)
#+abcl (progn (warn "Don't know how to get *gdl-home* on ABCL! Please find out.~%") #+abcl
nil)) (progn (warn "Don't know how to get *gdl-home* on ABCL! Please find out.~%")
nil))
;; ;;
...@@ -75,33 +81,36 @@ ...@@ -75,33 +81,36 @@
;; redefinition warnings until we get a better handle on ;; redefinition warnings until we get a better handle on
;; things. ;; things.
;; ;;
#-(or allegro lispworks sbcl) #-(or allegro lispworks sbcl clisp)
(warn "Need parameter for redefinition warnings for currently running lisp.~%") (warn "Need parameter for redefinition warnings for currently running lisp.~%")
(let (#+(or allegro lispworks) (let (#+(or allegro lispworks clisp)
(original-redefinition-warnings (original-redefinition-warnings
#+allegro excl:*redefinition-warnings* #+allegro excl:*redefinition-warnings*
#+lispworks lw:*redefinition-action*)) #+lispworks lw:*redefinition-action*
#+clisp custom:*suppress-check-redefinition*))
(defun begin-redefinitions-ok () (defun begin-redefinitions-ok ()
#+sbcl (declare (sb-ext:muffle-conditions sb-ext:compiler-note)) #+sbcl (declare (sb-ext:muffle-conditions sb-ext:compiler-note))
#+(or allegro lispworks) #+(or allegro lispworks clisp)
(setq #+allegro excl:*redefinition-warnings* (setq #+allegro excl:*redefinition-warnings*
#+lispworks lw:*redefinition-action* nil)) #+lispworks lw:*redefinition-action*
#+clisp custom:*suppress-check-redefinition* nil))
(defun end-redefinitions-ok () (defun end-redefinitions-ok ()
#+sbcl (declare (sb-ext:unmuffle-conditions sb-ext:compiler-note)) #+sbcl (declare (sb-ext:unmuffle-conditions sb-ext:compiler-note))
#+(or allegro lispworks) #+(or allegro lispworks clisp)
(setq #+allegro excl:*redefinition-warnings* (setq #+allegro excl:*redefinition-warnings*
#+lispworks lw:*redefinition-action* #+lispworks lw:*redefinition-action*
#+clisp custom:*suppress-check-redefinition*
original-redefinition-warnings))) 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.~%") (error "Need implementation for current-directory for currently running lisp.~%")
(defun current-directory () (defun current-directory ()
#+allegro (excl:current-directory) #+allegro (excl:current-directory)
#+lispworks (sys: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))) #+cmu (second (multiple-value-list (unix:unix-current-directory)))
#+ccl (ccl:current-directory) #+ccl (ccl:current-directory)
...@@ -115,7 +124,7 @@ ...@@ -115,7 +124,7 @@
,@(when doc (list doc)))) ,@(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.~%") (error "Need implementation for class-direct-superclasses for currently running lisp.~%")
(defun direct-superclasses (class) (defun direct-superclasses (class)
"Return a list of the direct superclasses." "Return a list of the direct superclasses."
...@@ -123,7 +132,7 @@ ...@@ -123,7 +132,7 @@
#+lispworks hcl:class-direct-superclasses #+lispworks hcl:class-direct-superclasses
#+sbcl sb-mop:class-direct-superclasses #+sbcl sb-mop:class-direct-superclasses
#+ccl ccl: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) (defun direct-superclass-names (class)
...@@ -135,32 +144,33 @@ ...@@ -135,32 +144,33 @@
(declare (ignore edition)) (declare (ignore edition))
(format t banner)) (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.~%") (error "Need implementation for eql-specializer for currently running lisp.~%")
(defun eql-specializer (attr-sym) (defun eql-specializer (attr-sym)
#+(or allegro abcl) (mop:intern-eql-specializer attr-sym) #+(or allegro abcl) (mop:intern-eql-specializer attr-sym)
#+(or lispworks cmu) (list 'eql attr-sym) #+(or lispworks cmu) (list 'eql attr-sym)
#+sbcl (sb-mop:intern-eql-specializer attr-sym) #+sbcl (sb-mop:intern-eql-specializer attr-sym)
#+ccl (ccl: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*)) (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) (defun featurep (x)
(#+allegro excl:featurep #+lispworks system:featurep #+sbcl sb-int:featurep (#+allegro excl:featurep #+lispworks system:featurep #+sbcl sb-int:featurep
#+ccl asdf::featurep #+abcl extensions:featurep #+ccl asdf::featurep #+abcl extensions:featurep
#+ecl find-feature x)) #+ecl find-feature
#+clisp ext:featurep x))
(defun gl-class-name (class) (defun gl-class-name (class)
"Return the class name." "Return the class name."
(#-cmu class-name #+cmu mop:class-name class)) (#-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.~%") (error "Need implementation for method-specializers for currently running lisp.~%")
(defun gl-method-specializers (method) (defun gl-method-specializers (method)
"Return a list of method specializers for the given method." "Return a list of method specializers for the given method."
...@@ -169,7 +179,7 @@ ...@@ -169,7 +179,7 @@
#+cmu pcl:method-specializers #+cmu pcl:method-specializers
#+sbcl sb-mop:method-specializers #+sbcl sb-mop:method-specializers
#+ccl ccl:method-specializers #+ccl ccl:method-specializers
#+ecl clos:method-specializers #+(or ecl clisp) clos:method-specializers
method)) method))
...@@ -203,7 +213,7 @@ ...@@ -203,7 +213,7 @@
#-allegro (make-hash-table))) #-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.~%") (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.~%") #+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) (defun make-weak-hash-table (&rest args)
...@@ -212,6 +222,8 @@ ...@@ -212,6 +222,8 @@
#+allegro :values #+allegro :weak #+allegro :values #+allegro :weak
#+lispworks :weak-kind #+lispworks t #+lispworks :weak-kind #+lispworks t
#+(or sbcl abcl) :weakness #+(or sbcl abcl) :key-and-value #+(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)) args))
(defun set-default-float-format () (defun set-default-float-format ()
...@@ -246,6 +258,7 @@ ...@@ -246,6 +258,7 @@
#+lispworks dspec:*source-pathname* #+lispworks dspec:*source-pathname*
#+sbcl (error "need source-pathname in sbcl~%") #+sbcl (error "need source-pathname in sbcl~%")
#+ccl (error "need source-pathname in ccl~%") #+ccl (error "need source-pathname in ccl~%")
#+clisp (error "need source-pathname in ccl~%")
#+abcl (extensions:source-pathname) #+abcl (extensions:source-pathname)
) )
...@@ -272,13 +285,11 @@ ...@@ -272,13 +285,11 @@
(:case-sensitive-lower string))) (:case-sensitive-lower string)))
(defmacro w-o-interrupts (&body body) (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.~%") (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) (error "Need implementation for without-interrupts for currently running lisp.~%") #-(or allegro lispworks cmu sbcl ccl abcl clisp)
`(#+allegro excl:without-interrupts (error "Need implementation for without-interrupts for currently running lisp.~%")
#+lispworks progn `(#+allegro progn ;; excl:without-interrupts
#+ccl progn #+(or lispworks ccl abcl ecl clisp) progn
#+abcl progn
#+ecl progn
#+cmu system:without-interrupts #+cmu system:without-interrupts
#+sbcl sb-sys:without-interrupts #+sbcl sb-sys:without-interrupts
,@body)) ,@body))
...@@ -328,11 +339,6 @@ ...@@ -328,11 +339,6 @@
#+lispworks compiler:*produce-xref-info* #+lispworks compiler:*produce-xref-info*
t)) 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) (defmacro without-package-variance-warnings (&body body)
`(eval-when (:compile-toplevel :load-toplevel :execute) `(eval-when (:compile-toplevel :load-toplevel :execute)
......
...@@ -22,7 +22,7 @@ ...@@ -22,7 +22,7 @@
(in-package :common-lisp-user) (in-package :common-lisp-user)
(eval-when (:compile-toplevel :load-toplevel :execute) (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, 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. 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 ...@@ -324,6 +324,7 @@ If you are interested in this effort we would love to hear from you at open-sour
#:gc-full #:gc-full
#:get-backtrace #:get-backtrace
#:initialize-multiprocessing #:initialize-multiprocessing
#:local-port
#:match-regexp #:match-regexp
#:patches-dir #:patches-dir
#:process-run-function #:process-run-function
...@@ -333,6 +334,7 @@ If you are interested in this effort we would love to hear from you at open-sour ...@@ -333,6 +334,7 @@ If you are interested in this effort we would love to hear from you at open-sour
#:slot-definition-name #:slot-definition-name
#:socket-bytes-written #:socket-bytes-written
#:split-regexp #:split-regexp
#:with-heuristic-case-mode
#:with-timeout-sym #:with-timeout-sym
;; ;;
......
...@@ -90,10 +90,12 @@ ...@@ -90,10 +90,12 @@
(when (and *compile-for-dgdl?* (not (eql attr-sym 'gdl-acc::type))) (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) `(unless (find-method (symbol-function ',(glisp:intern attr-sym :gdl-inputs))
,part-arg nil (list (find-class 'gdl-remote) t (find-class 'gdl-basis)) nil)
(,self-arg gdl-basis)) (defmethod ,(glisp:intern attr-sym :gdl-inputs) ((,parent-arg gdl-remote)
(the-object ,parent-arg (fetch-input ,(make-keyword attr-sym) ,part-arg ,self-arg)))) ,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) `(defmethod ,(glisp:intern (symbol-name attr-sym) :gdl-slots) ((self ,name) &rest ,args-arg)
(declare (ignore ,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.\" ...@@ -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 slot) :gdl-acc) :initarg ,(make-keyword slot))
`(,(glisp:intern (symbol-name (first slot)) :gdl-acc) :initform ,(second slot) `(,(glisp:intern (symbol-name (first slot)) :gdl-acc) :initform ,(second slot)
:initarg ,(make-keyword (first slot)) :initarg ,(make-keyword (first slot))
:documentation ,(third slot)))) :documentation ,(or (third slot) ""))))
slots) (:metaclass gdl-format-class)) slots) (:metaclass gdl-format-class))
(let ((,class (find-class ',name))) (let ((,class (find-class ',name)))
(let ((,old-format-functions (format-functions ,class)) (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 ...@@ -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) (the (send-output (:apply (cons ,(make-keyword attr-sym)
(cons *%format%* ,args-arg)))))))))) (cons *%format%* ,args-arg))))))))))
(eval-when (:compile-toplevel :load-toplevel :execute) (glisp:end-redefinitions-ok)) (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 (and *compile-documentation-database?* attr-remarks)
`(when *load-documentation-database?* (setf (documentation ,method nil) ,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 ...@@ -254,41 +254,41 @@ Defaults to nil (i.e. we assume we are loading into a clean system and need all
(asdf-system-list (asdf-system-list
(let ((binaries (the compile-and-load))) (let ((binaries (the compile-and-load)))
(append `(asdf:defsystem ,(read-from-string (format nil "#:~a" (pathname-name (the asd-file)))) (append `(asdf:defsystem ,(read-from-string (format nil "#:~a" (pathname-name (the asd-file))))
:description "Auto-generated asdf defsys from Genworks GDL cl-lite." :description "Auto-generated asdf defsys from Genworks GDL cl-lite."
:author "Genworks and Dave Cooper unless otherwise indicated" :author "Genworks and Dave Cooper unless otherwise indicated"
:license "AGPL unless otherwise indicated" :license "AGPL unless otherwise indicated"
:serial t :serial t
:version ,(string-append :version ,(string-append
(replace-substring (iso-8601-date (get-universal-time)) "-" "") "00") (replace-substring (iso-8601-date (get-universal-time)) "-" "") "00")
:depends-on ,(the asdf-depends-on) :depends-on ,(the asdf-depends-on)
;; ;;
;; FLAG -- maybe can get rid of binaries and need to call (the compile-and-load) ;; FLAG -- maybe can get rid of binaries and need to call (the compile-and-load)
;; ;;
:components ,(mapcar #'(lambda(binary source) :components ,(mapcar #'(lambda(binary source)
(let ((binary (make-pathname :directory (remove "bin" (let ((binary (make-pathname :directory (remove "bin"
(pathname-directory binary) (pathname-directory binary)
:test #'string-equal) :test #'string-equal)
:defaults binary))) :defaults binary)))
(let ((namestring (replace-substring (let ((namestring (replace-substring
(namestring (namestring
(make-pathname :name (pathname-name binary) (make-pathname :name (pathname-name binary)
:type nil ;;(pathname-type source) :type nil ;;(pathname-type source)
:defaults :defaults
(enough-namestring binary (the ppathname)))) (enough-namestring binary (the ppathname))))
"\\" "/"))) "\\" "/")))
(list (if (string-equal (pathname-type source) "lisp") (list (if (string-equal (pathname-type source) "lisp")
:file :file
(make-keyword (pathname-type source))) (make-keyword (pathname-type source)))
namestring) namestring)
#+nil #+nil
(list :file namestring (list :file namestring
:pathname :pathname
(merge-pathnames namestring ""))))) (merge-pathnames namestring "")))))
binaries (the source-file-list))))) binaries (the source-file-list)))))
:uncached) :uncached)
...@@ -331,7 +331,8 @@ Defaults to nil (i.e. we assume we are loading into a clean system and need all ...@@ -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-exists :supersede
:if-does-not-exist :create) :if-does-not-exist :create)
(let ((*print-right-margin* 70) (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) (pprint (the asdf-system-list) out)
(when (the additional-asd-code) (when (the additional-asd-code)
(format out "~%~%") (format out "~%~%")
......
...@@ -21,15 +21,14 @@ ...@@ -21,15 +21,14 @@
(in-package :com.genworks.lisp) (in-package :com.genworks.lisp)
(defparameter *fasl-extension* (defparameter *fasl-extension*
#+allegro excl:*fasl-default-type* #+allegro excl:*fasl-default-type*
#+lispworks compiler:*fasl-extension-string* #+lispworks compiler:*fasl-extension-string*
#+sbcl sb-fasl:*fasl-file-type* #+sbcl sb-fasl:*fasl-file-type*
#+ccl (namestring ccl:*.fasl-pathname*) #+ccl (namestring ccl:*.fasl-pathname*)
#+abcl "abcl" #+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) #-(or allegro lispworks sbcl ccl)
...@@ -101,7 +100,14 @@ and \"..\" entries." ...@@ -101,7 +100,14 @@ and \"..\" entries."
:directories t) :directories t)
#+abcl #+abcl
(directory (merge-pathnames *wild-entry* pathspec) (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) (defun file-directory-p (file)
......
(in-package :com.genworks.lisp) (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 () (defun get-pid ()
#+allegro (excl.osi:getpid) #+allegro (excl.osi:getpid)
#+lispworks (multiple-value-bind (status pid) #+lispworks (multiple-value-bind (status pid)
...@@ -48,9 +48,24 @@ ...@@ -48,9 +48,24 @@
:collecting (code-char b) :into result :collecting (code-char b) :into result
:finally (return :finally (return
(parse-integer (coerce result 'string))))) (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) (defun run-gs (command)
......
...@@ -114,7 +114,7 @@ meaning the crosshairs will remain the same size regardless of zoom state." ...@@ -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 :output-functions
((cad-output