Commit 58cac74f authored by Dave Cooper's avatar Dave Cooper
Browse files

Porting to SBCL. gdl-base is compiling and passing basic tests, next the...

Porting to SBCL. gdl-base is compiling and passing basic tests, next the cl-lite/source/genworks.lisp needs sbcl directives added to it.
parent aa4b39d0
......@@ -44,8 +44,9 @@
(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")))))
(base (when (>= (length full-name)(length "-2011010100"))
(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/"
......@@ -127,10 +128,14 @@
;; 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))
(ensure-directories-exist (merge-pathnames "SMLib8.40/" (the target-parent)))
(glisp:copy-file (merge-pathnames (format nil "../../common/SMLib8.40/libs/~a/~a"
#+linux "linux"
#+mswindows "windows"
#+macosx "macos"
(glisp:smlib-name))
glisp:*genworks-source-home*)
(merge-pathnames (format nil "SMLib8.18/~a" (glisp:smlib-name))
(merge-pathnames (format nil "SMLib8.40/~a" (glisp:smlib-name))
(the target-parent)))
;;
......
......@@ -9,8 +9,12 @@ 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/Emacs.app/Contents/MacOS/Emacs --no-splash --no-init-file -l devo.el $@
if [ "$1" == "sbcl" ]; then
cl_platform='SBCL'
else
cl_platform='LispWorks'
fi
/Applications/Emacs.app/Contents/MacOS/Emacs --no-splash --no-init-file -l devo.el
fi
......@@ -10,7 +10,12 @@
(setq slime-lisp-implementations
(cond ((and (string= (getenv "cl_platform") "LispWorks")
(string= (getenv "os_platform") "Darwin"))
'((lw60-macosx-x86 ("../../common/lw60-macosx-x86/lw-console"))))
'((lw60-macosx-x86 ("../../common/lw60-macosx-x86/lw-console"))
(sbcl-1.0.52-x86-64-darwin ("sbcl"))))
((and (string= (getenv "cl_platform") "SBCL")
(string= (getenv "os_platform") "Darwin"))
'((sbcl-1.0.52-x86-64-darwin ("sbcl"))
(lw60-macosx-x86 ("../../common/lw60-macosx-x86/lw-console"))))
((and (string= (getenv "cl_platform") "Allegro")
(string= (getenv "os_platform") "Linux"))
'((acl82m-linux-x86 ("../../common/acl82-linux-x86/mlisp"))
......
......@@ -21,22 +21,26 @@
(in-package :gdl)
#-(or allegro lispworks sbcl) (error "Need package for mop:validate-superclass for currently running lisp.~%")
(eval-when (compile load eval)
(defpackage :com.genworks.lisp
(:use :common-lisp)
(:shadow #:intern)
(:nicknames :glisp)
(:import-from #+allegro :mop #+lispworks :hcl #+sbcl :sb-mop
#:validate-superclass)
(:export #:*external-text-format*
#:*gdl-home*
#:*genworks-source-home*
#:basic-command-line-arguments
#:begin-redefinitions-ok
#:current-directory
#:define-constant
#:direct-superclasses
#:direct-superclass-names
#:display-startup-banner
#:end-redefinitions-ok
#:eql-specializer
#:get-backtrace
#:gl-class-name
#:gl-method-specializers
#:hex-string-to-integer
......@@ -53,8 +57,7 @@
#:w-o-interrupts
#:xref-off
#:xref-on
#:display-startup-banner
)))
#:validate-superclass)))
(in-package :com.genworks.lisp)
......@@ -74,38 +77,52 @@
(defparameter *gdl-home* (merge-pathnames "../../common/" *genworks-source-home*))
#-(or allegro lispworks) (error "Need implementation for command-line-arguments in currently running lisp.~%")
#-(or allegro lispworks sbcl) (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*)
#+lispworks system:*line-arguments-list*
#+sbcl sb-ext:*posix-argv*)
#-(or allegro lispworks)
#-(or allegro lispworks sbcl)
(error "Need parameter for redefinition warnings for currently running lisp.~%")
(let ((original-redefinition-warnings
#+allegro excl:*redefinition-warnings*
#+lispworks lw:*redefinition-action*))
(defun begin-redefinitions-ok ()
#+sbcl (declaim (sb-ext:muffle-conditions sb-ext:compiler-note))
#+(or allegro lispworks)
(setq #+allegro excl:*redefinition-warnings*
#+lispworks lw:*redefinition-action* nil))
(defun end-redefinitions-ok ()
#+sbcl (declaim (sb-ext:unmuffle-conditions sb-ext:compiler-note))
#+(or allegro lispworks)
(setq #+allegro excl:*redefinition-warnings*
#+lispworks lw:*redefinition-action* original-redefinition-warnings)))
#-(or allegro lispworks cmu)
#-(or allegro lispworks cmu sbcl)
(error "Need implementation for current-directory for currently running lisp.~%")
(defun current-directory ()
#+allegro (excl:current-directory)
#+lispworks (sys:current-directory)
#+sbcl *default-pathname-defaults*
#+cmu (second (multiple-value-list (unix:unix-current-directory))))
;;
;; From SBCL manual (to avoid redef errors when compiling/loading defconstants in SBCL):
;;
(defmacro define-constant (name value &optional doc)
`(defconstant ,name (if (boundp ',name) (symbol-value ',name) ,value)
,@(when doc (list doc))))
#-(or allegro lispworks)
#-(or allegro lispworks sbcl)
(error "Need implementation for class-direct-superclasses for currently running lisp.~%")
(defun direct-superclasses (class)
"Return a list of the direct superclasses."
(#+allegro mop:class-direct-superclasses
#+lispworks hcl:class-direct-superclasses class))
#+lispworks hcl:class-direct-superclasses
#+sbcl sb-mop:class-direct-superclasses class))
(defun direct-superclass-names (class)
......@@ -113,49 +130,27 @@
(mapcar #'gl-class-name
(direct-superclasses class)))
#-(or allegro lispworks cmu)
#-(or allegro lispworks cmu sbcl)
(error "Need implementation for eql-specializer for currently running lisp.~%")
(defun eql-specializer (attr-sym)
#+allegro (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))
;;
;; I believe this is from Hunchentoot:
;;
#-allegro (warn "Need full implementation for get-backtrace for currently running lisp. See Hunchentoot for a cross-platform implementation.~%")
(defun get-backtrace (error)
(with-output-to-string (s)
(with-standard-io-syntax
(let ((*print-readably* nil)
(*print-miser-width* 40)
(*print-pretty* t)
#+allegro(tpl:*zoom-print-circle* t)
#+allegro(tpl:*zoom-print-level* nil)
#+allegro(tpl:*zoom-print-length* nil))
(ignore-errors
(format *terminal-io* "~
~@<An unhandled error condition has been signalled:~3I ~a~I~:@>~%~%"
error))
(ignore-errors
(let ((*terminal-io* s)
(*standard-output* s))
#+allegro(tpl:do-command "zoom"
:from-read-eval-print-loop nil
:count t
:all t)))))))
(defun gl-class-name (class)
"Return the class name."
(#-cmu class-name #+cmu mop:class-name class))
#-(or allegro lispworks cmu)
(error "Need implementation for class-direct-superclasses for currently running lisp.~%")
#-(or allegro lispworks cmu sbcl)
(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."
(#+allegro mop:method-specializers
(#+allegro mop:method-specializers
#+lispworks hcl:method-specializers
#+cmu pcl:method-specializers method))
#+cmu pcl:method-specializers
#+sbcl sb-mop:method-specializers method))
(defun hex-string-to-integer (string)
......@@ -188,11 +183,13 @@
#-allegro (make-hash-table)))
#-(or allegro lispworks) (error "Need implementation for make-weak-hash-table for currently running lisp.~%")
#-(or allegro lispworks sbcl) (error "Need implementation for make-weak-hash-table for currently running lisp.~%")
(defun make-weak-hash-table (&rest args)
(apply #'make-hash-table #+allegro :weak-keys #+allegro t
(apply #'make-hash-table
#+allegro :weak-keys #+allegro t
#+allegro :values #+allegro :weak
#+lispworks :weak-kind #+lispworks t
#+sbcl :weakness #+sbcl :key-or-value
args))
(defun set-default-float-format ()
......@@ -220,9 +217,6 @@
(excl:console-control :title "Genworks GDL Console")
(retitle-emacs))
#-allegro
(warn "Find out how to retitle Emacs window in currently running environment.")
(defun retitle-emacs (&key (title "Genworks GDL Interactive Authoring Environment"))
"Retitles the associated GDL emacs window with the specified title.
......@@ -244,14 +238,20 @@
(defmacro w-o-interrupts (&body body)
(warn "Without-interrupts is deprecated in multiprocessing Lisp - replace usage with something else.")
#-(or allegro lispworks cmu) (error "Need implementation for without-interrupts for currently running lisp.~%")
#-(or allegro lispworks cmu sbcl) (error "Need implementation for without-interrupts for currently running lisp.~%")
`(#+allegro excl:without-interrupts
#+lispworks progn
#+cmu system:without-interrupts
#+sbcl sb-sys:without-interrupts
,@body))
#-(or allegro lispworks)
#-(or allegro lispworks)
(warn "Need implementation for xref-off for the currently running lisp.~%")
#-(or allegro lispworks)
(defun xref-off (&optional include-source-info?)
(declare (ignore include-source-info?))
(warn "Need implementation for xref-off for the currently running lisp.~%"))
#+(or allegro lispworks)
(defun xref-off (&optional include-source-info?)
(when include-source-info?
(setq #+allegro excl:*load-source-file-info*
......@@ -269,6 +269,11 @@
#-(or allegro lispworks)
(warn "Need implementation for xref-off for the currently running lisp.~%")
#-(or allegro lispworks)
(defun xref-on (&optional include-source-info?)
(declare (ignore include-source-info?))
(warn "Need implementation for xref-off for the currently running lisp.~%"))
#+(or allegro lispworks)
(defun xref-on (&optional include-source-info?)
(when include-source-info?
......
......@@ -28,7 +28,6 @@
(:file "rest/source/vanilla-mixin")
(: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")
......
......@@ -68,6 +68,6 @@
(defclass gdl-skin-class (standard-class) ())
(defmethod validate-superclass ((class gdl-class) (superclass standard-class)) t)
(defmethod validate-superclass ((class gdl-format-class) (superclass standard-class)) t)
(defmethod validate-superclass ((class gdl-skin-class) (superclass standard-class)) t)
(defmethod glisp:validate-superclass ((class gdl-class) (superclass standard-class)) t)
(defmethod glisp:validate-superclass ((class gdl-format-class) (superclass standard-class)) t)
(defmethod glisp:validate-superclass ((class gdl-skin-class) (superclass standard-class)) t)
......@@ -126,7 +126,7 @@ values are a color indicator for the default foreground and background of graphi
(defparameter *error-on-not-handled?* t)
(defconstant +reserved-words+
(glisp:define-constant +reserved-words+
(mapcar #'(lambda(symbol)
(glisp:intern symbol :gdl-acc))
'(aggregate
......
......@@ -21,19 +21,19 @@
(in-package :gdl)
(defconstant 2pi (* 2 pi)
(glisp:define-constant 2pi (* 2 pi)
"Number (Constant). Twice the internal Lisp value for pi.")
(defconstant pi/2 (/ pi 2)
(glisp:define-constant pi/2 (/ pi 2)
"Number (Constant). Half the internal Lisp value for pi.")
(defconstant +phi+ 1.618
(glisp:define-constant +phi+ 1.618
"Number (Constant). The Golden Ratio.")
(defparameter *zero-epsilon* 0.001
"Number. The value used to test for closeness to zero in some functions. Defaults to 0.001")
(defconstant +kappa+ 0.5522847498307936d0)
(glisp:define-constant +kappa+ 0.5522847498307936d0)
(defvar *current-version* nil)
......
(:gdl-base :gdl-cl-lite :aserve :cl-who :cl-ppcre :cl-base64)
(:gdl-base :gdl-cl-lite :aserve :cl-who :cl-ppcre :cl-base64 :trivial-backtrace)
......@@ -6,13 +6,14 @@
:license "AGPL unless otherwise indicated" :serial t
:version "2011101700" :depends-on
(:gdl-base :gdl-cl-lite :aserve :cl-who :cl-ppcre
:cl-base64)
:cl-base64 :trivial-backtrace)
:components
((:file "source/package") (:file "source/genworks")
(:file "source/defparameters")
(:file "source/base-html-sheet")
(:file "source/base-html-utils")
(:file "source/macros") (:file "source/initialize")
(:file "source/macros") (:file "source/ignore-errors-with-backtrace")
(:file "source/initialize")
(:file "source/utilities") (:file "source/answer")
(:file "source/accessories")
(:file "source/gdl-remote")
......
......@@ -21,7 +21,7 @@
("package" "genworks" "defparameters"
"base-html-sheet" "base-html-utils"
"macros" "initialize" "utilities" "answer"
"macros" "ignore-errors-with-backtrace" "initialize" "utilities" "answer"
"accessories" "layout-mixin"
"application-mixin" "gdl-remote" "vanilla-remote")
......@@ -6,8 +6,8 @@
(:export #:*base64-encode-func*
#:*base64-decode-func*
#:class-slots
#:slot-definition-name
#:gc-full
#:get-backtrace
#:initialize-multiprocessing
#:load-html-parser
#:match-regexp
......@@ -15,12 +15,10 @@
#:process-run-function
#:remote-host
#:replace-regexp
#:slot-definition-name
#:socket-bytes-written
#:split-regexp
#:with-timeout-sym
)))
#:with-timeout-sym)))
(defparameter *base64-encode-func*
#'cl-base64:string-to-base64-string)
......@@ -28,16 +26,26 @@
(defparameter *base64-decode-func*
#'cl-base64:base64-string-to-string)
(defun class-slots (class)
#-(or allegro lispworks) (error "Need implementation for class-slots for currently running lisp.~%")
(#+allegro mop:class-slots
#+lispworks hcl:class-slots class))
(defun slot-definition-name (slot-definition)
#-(or allegro lispworks) (error "Need implementation for slot-definition-name for currently running lisp.~%")
(#+allegro mop:slot-definition-name
#+lispworks hcl:slot-definition-name slot-definition))
;;
;; from Hunchentoot:
;;
(defun get-backtrace ()
"Returns a string with a backtrace of what the Lisp system thinks is
the \"current\" error."
(handler-case
(with-output-to-string (s)
(trivial-backtrace:print-backtrace-to-stream s))
(error (condition)
(format nil "Could not generate backtrace: ~A." condition))))
(defun gc-full ()
......@@ -86,6 +94,11 @@
(defun replace-regexp (string regexp to-string)
(cl-ppcre:regex-replace-all regexp string to-string))
(defun slot-definition-name (slot-definition)
#-(or allegro lispworks) (error "Need implementation for slot-definition-name for currently running lisp.~%")
(#+allegro mop:slot-definition-name
#+lispworks hcl:slot-definition-name slot-definition))
(defun socket-bytes-written (socket)
#-allegro (declare (ignore socket))
#+allegro (excl::socket-bytes-written socket)
......@@ -94,7 +107,6 @@
please find implementation for the currently running lisp.~%")
0))
(defun split-regexp (regexp string)
(cl-ppcre:split regexp string))
......
;;
;; Copyright 2002-2011 Genworks International and Genworks BV
;;
;; This source file is part of the General-purpose Declarative
;; Language project (GDL).
;;
;; This source file 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 source file 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 this source file. If not, see
;; <http://www.gnu.org/licenses/>.
;;
(in-package :gdl)
(defmacro ignore-errors-with-backtrace (&body body)
"Like IGNORE-ERRORS, but in case of failure, return backtrace string as third value."
`(block %debug-escape
(handler-bind
((error (lambda (condition)
(let ((backtrace (glisp:get-backtrace)))
(return-from %debug-escape (values nil condition backtrace))))))
,@body)))
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