[bknr-cvs] hans changed trunk/
BKNR Commits
bknr at bknr.net
Fri Jul 25 16:46:19 UTC 2008
Revision: 3644
Author: hans
URL: http://bknr.net/trac/changeset/3644
Revive cmucl support for BOS.
U trunk/bknr/datastore/src/utils/acl-mp-compat.lisp
U trunk/bknr/datastore/src/utils/package.lisp
U trunk/clean.lisp
A trunk/projects/bos/Makefile.cmucl
U trunk/projects/bos/build.lisp
U trunk/projects/bos/m2/m2-pdf.lisp
U trunk/projects/bos/m2/packages.lisp
U trunk/projects/bos/web/bos.web.asd
U trunk/projects/bos/web/packages.lisp
U trunk/projects/bos/web/webserver.lisp
A trunk/projects/bos/web/website-language.lisp
U trunk/thirdparty/bordeaux-threads_0.4.0/src/cmu.lisp
Modified: trunk/bknr/datastore/src/utils/acl-mp-compat.lisp
===================================================================
--- trunk/bknr/datastore/src/utils/acl-mp-compat.lisp 2008-07-25 16:24:06 UTC (rev 3643)
+++ trunk/bknr/datastore/src/utils/acl-mp-compat.lisp 2008-07-25 16:46:19 UTC (rev 3644)
@@ -55,17 +55,17 @@
(error "missing port for this compiler, please provide for multiprocessing primitives for this compiler in ~A" *load-pathname*)
(defun make-process (function &key name)
- #+sbcl(sb-thread:make-thread function :name name)
- #+openmcl(ccl:process-run-function name function)
- #+cmu(mp:make-process function :name name))
+ #+sbcl (sb-thread:make-thread function :name name)
+ #+openmcl (ccl:process-run-function name function)
+ #+cmu (mp:make-process function :name name))
(defun destroy-process (process)
- #+sbcl(sb-thread:destroy-thread process)
- #+openmcl(ccl:process-kill process)
- #+cmu(mp:destroy-process process))
+ #+sbcl (sb-thread:destroy-thread process)
+ #+openmcl (ccl:process-kill process)
+ #+cmu (mp:destroy-process process))
(defun process-active-p (process)
- #+sbcl(sb-thread:thread-alive-p process)
- #+openmcl(ccl::process-active-p process)
- #+cmu(mp:process-active-p process))
+ #+sbcl (sb-thread:thread-alive-p process)
+ #+openmcl (ccl::process-active-p process)
+ #+cmu (mp:process-active-p process))
Modified: trunk/bknr/datastore/src/utils/package.lisp
===================================================================
--- trunk/bknr/datastore/src/utils/package.lisp 2008-07-25 16:24:06 UTC (rev 3643)
+++ trunk/bknr/datastore/src/utils/package.lisp 2008-07-25 16:46:19 UTC (rev 3644)
@@ -6,7 +6,6 @@
:cl-interpol
:md5
#+sbcl :sb-ext
- #+cmu :mp
#+openmcl :ccl)
#+openmcl
(:shadow :ccl #:copy-file #:make-process)
Modified: trunk/clean.lisp
===================================================================
--- trunk/clean.lisp 2008-07-25 16:24:06 UTC (rev 3643)
+++ trunk/clean.lisp 2008-07-25 16:46:19 UTC (rev 3644)
@@ -3,6 +3,11 @@
;; BKNR build script - Called by buildbot to clean up fasls
(format t "; cleaning fasls in ~A~%" (probe-file *default-pathname-defaults*))
-(mapc #'delete-file (directory (compile-file-pathname #P"**/*.lisp")))
+(mapc #'delete-file
+ (directory
+ (merge-pathnames (make-pathname :name :wild
+ :directory '(:relative :wild-inferiors)
+ :type (pathname-type (compile-file-pathname "")))
+ (probe-file *default-pathname-defaults*))))
Added: trunk/projects/bos/Makefile.cmucl
===================================================================
--- trunk/projects/bos/Makefile.cmucl (rev 0)
+++ trunk/projects/bos/Makefile.cmucl 2008-07-25 16:46:19 UTC (rev 3644)
@@ -0,0 +1,29 @@
+LISP=lisp -noinit
+all: bos.core
+.PHONY: all
+
+bos.core: build.lisp
+ $(LISP) -load build.lisp -eval '(ext:save-lisp "bos.core")'
+
+# various cleaning stuff
+.PHONY: cleancore
+cleancore:
+ rm -f bos.core
+
+.PHONY: cleanfasl
+cleanfasl:
+ (cd ../.. && $(LISP) -load clean.lisp -eval '(quit)')
+
+.PHONY: cleanall
+cleanall: cleancore cleanfasl
+
+.PHONY: clean
+clean: cleancore
+
+.PHONY: start
+start: bos.core
+ $(LISP) -dynamic-space-size 800 -core bos.core -eval '(start)'
+
+# TAGS
+TAGS:
+ find . -name '*.lisp' | xargs etags -a
Modified: trunk/projects/bos/build.lisp
===================================================================
--- trunk/projects/bos/build.lisp 2008-07-25 16:24:06 UTC (rev 3643)
+++ trunk/projects/bos/build.lisp 2008-07-25 16:46:19 UTC (rev 3644)
@@ -1,18 +1,22 @@
;;; a quick startup script that can be loaded with all supported lisps
(in-package :cl-user)
-#+cmu(load (compile-file "../../bknr/patches/patch-around-mop-cmucl19a.lisp"))
+#+sbcl (require 'asdf)
+#+sbcl (require 'sb-posix)
-#+sbcl(require 'asdf)
-#+sbcl(require 'sb-posix)
+#+sbcl (assert (eql sb-impl::*default-external-format* :utf-8))
+#+cmu
+(setf stream:*default-external-format* :utf-8
+ ext:*gc-verbose* nil
+ *compile-print* nil
+ ext:*bytes-consed-between-gcs* (* 64 1024 1024)
+ *default-pathname-defaults* (pathname (format nil "~A/" (nth-value 1 (unix:unix-current-directory)))))
-#+sbcl(assert (eql sb-impl::*default-external-format* :utf-8))
-
(load (compile-file "../../thirdparty/asdf/asdf.lisp"))
;; cl-gd glue
-#+darwin(assert (zerop (asdf:run-shell-command "cd ../../thirdparty/cl-gd-0.5.6; make cl-gd-glue.dylib")))
-#-darwin(assert (zerop (asdf:run-shell-command "cd ../../thirdparty/cl-gd-0.5.6; make")))
+#+darwin (assert (zerop (asdf:run-shell-command "cd ../../thirdparty/cl-gd-0.5.6; make cl-gd-glue.dylib")))
+#-darwin (assert (zerop (asdf:run-shell-command "cd ../../thirdparty/cl-gd-0.5.6; make")))
;;; some helpers
(defun setup-registry ()
@@ -22,7 +26,7 @@
(pushnew (make-pathname :directory (pathname-directory asd-pathname))
asdf:*central-registry*
:test #'equal))
- (directory #p"../../**/*.asd")))
+ (directory (merge-pathnames #p"**/*.asd" (truename "../../")))))
(defun read-configuration (pathname)
(with-open-file (s pathname)
@@ -37,23 +41,26 @@
;;; load bos project
(asdf:oos 'asdf:load-op :bos.web)
+#+sbcl
(defvar *sbcl-home* (sb-int:sbcl-homedir-pathname))
+#+sbcl
(defun ensure-sbcl-home ()
(sb-posix:putenv (format nil "SBCL_HOME=~a" *sbcl-home*)))
(defun env-ascii-check ()
- #+sbcl(assert (block top
- (dolist (string (posix-environ) t)
- (loop for ch across string
- unless (< 0 (char-code ch) 128)
- do (return-from top nil))))
- nil
- "We will have a problem if your environment contains anything else than ASCII characters.~
+ #+sbcl
+ (assert (block top
+ (dolist (string (posix-environ) t)
+ (loop for ch across string
+ unless (< 0 (char-code ch) 128)
+ do (return-from top nil))))
+ nil
+ "We will have a problem if your environment contains anything else than ASCII characters.~
~%So I'd like to enforce this here."))
(defun start (&key (swank-port 4005))
- (ensure-sbcl-home)
+ #+sbcl (ensure-sbcl-home)
(env-ascii-check)
;; check for changes that are not yet in the core
(asdf:oos 'asdf:load-op :bos.web)
@@ -72,7 +79,9 @@
(apply #'bos.web::init (read-configuration "web.rc"))
(bos.web::start-contract-tree-image-update-daemon)
(bos.m2::start-postmaster)
- (bknr.cron::start-cron))
+ (bknr.cron::start-cron)
+ #+(and cmu mp)
+ (mp::startup-idle-and-top-level-loops))
(defun start-cert-daemon ()
(ensure-sbcl-home)
Modified: trunk/projects/bos/m2/m2-pdf.lisp
===================================================================
--- trunk/projects/bos/m2/m2-pdf.lisp 2008-07-25 16:24:06 UTC (rev 3643)
+++ trunk/projects/bos/m2/m2-pdf.lisp 2008-07-25 16:46:19 UTC (rev 3644)
@@ -65,7 +65,7 @@
;; cl-pdf does not really handle non-ascii characters in a very
;; usable manner. In order to avoid having to deal with
;; embedding fonts and encoding, just work around the issue:
- (princ (remove #\Latin_Capital_Letter_A_With_Circumflex
+ (princ (remove (code-char 194)
(with-output-to-string (s)
(let ((pdf:*compress-streams* nil))
(pdf:write-document s))))
Modified: trunk/projects/bos/m2/packages.lisp
===================================================================
--- trunk/projects/bos/m2/packages.lisp 2008-07-25 16:24:06 UTC (rev 3643)
+++ trunk/projects/bos/m2/packages.lisp 2008-07-25 16:46:19 UTC (rev 3644)
@@ -272,8 +272,6 @@
(defpackage :bos.m2.cert-generator
(:use :cl
- #+cmu :extensions
- #+sbcl :sb-ext
:bos.m2.config
:bknr.utils
:cl-ppcre
Modified: trunk/projects/bos/web/bos.web.asd
===================================================================
--- trunk/projects/bos/web/bos.web.asd 2008-07-25 16:24:06 UTC (rev 3643)
+++ trunk/projects/bos/web/bos.web.asd 2008-07-25 16:46:19 UTC (rev 3644)
@@ -37,7 +37,9 @@
(:file "contract-tree" :depends-on ("quad-tree"))
(:file "sat-tree" :depends-on ("quad-tree" "contract-tree"))
(:file "countries" :depends-on ("packages"))
+ (:file "website-language" :depends-on ("packages"))
(:file "kml-handlers" :depends-on ("packages"
+ "website-language"
"web-macros"
"countries"
"dictionary"))
@@ -52,6 +54,7 @@
(:file "contract-rss" :depends-on ("web-utils"))
(:file "webserver" :depends-on ("news-tags"
"tags"
+ "website-language"
"map-handlers"
"map-browser-handler"
"poi-handlers"
Modified: trunk/projects/bos/web/packages.lisp
===================================================================
--- trunk/projects/bos/web/packages.lisp 2008-07-25 16:24:06 UTC (rev 3643)
+++ trunk/projects/bos/web/packages.lisp 2008-07-25 16:46:19 UTC (rev 3644)
@@ -4,15 +4,12 @@
(:nicknames :web :worldpay-test)
(:use :cl
:date-calc
- #+cmu :extensions
- #+sbcl :sb-ext
:cl-user
:cl-interpol
:cl-ppcre
:xhtml-generator
:cxml
:puri
- #+(or) :mime
:bknr.web
:bknr.web.frontend
:bknr.datastore
Modified: trunk/projects/bos/web/webserver.lisp
===================================================================
--- trunk/projects/bos/web/webserver.lisp 2008-07-25 16:24:06 UTC (rev 3643)
+++ trunk/projects/bos/web/webserver.lisp 2008-07-25 16:46:19 UTC (rev 3644)
@@ -57,45 +57,6 @@
(cons :language (request-language)))
(call-next-method)))
-(define-persistent-class website-language ()
- ((code :read :index-type string-unique-index :index-reader language-with-code)
- (name :read :index-type string-unique-index)))
-
-(defun website-languages ()
- (mapcar #'(lambda (language) (list (website-language-code language)
- (website-language-name language)))
- (class-instances 'website-language)))
-
-(defun website-supports-language (language)
- (find language (website-languages) :test #'string-equal :key #'car))
-
-(defun language-from-url (path)
- (register-groups-bind (language) (#?r"^/(..)/" path)
- (when (website-supports-language language)
- language)))
-
-(defun find-browser-prefered-language ()
- "Determine the language prefered by the user, as determined by the Accept-Language header
-present in the HTTP request. Header decoding is done according to RFC2616, considering individual
-language preference weights."
- (let ((accept-language (hunchentoot:header-in* :accept-language)))
- (dolist (language (mapcar #'car
- (sort (mapcar #'(lambda (language-spec-string)
- (if (find #\; language-spec-string)
- (destructuring-bind (language preference-string)
- (split #?r" *; *q=" language-spec-string)
- (cons language (read-from-string preference-string)))
- (cons language-spec-string 1)))
- (split #?r" *, *" accept-language))
- #'> :key #'cdr)))
- (when (website-supports-language language)
- (return-from find-browser-prefered-language language))
- (register-groups-bind (language variant) (#?r"^(.*)-(.*)$" language)
- (declare (ignore variant))
- (when (website-supports-language language)
- (return-from find-browser-prefered-language language)))))
- nil)
-
(defclass index-handler (page-handler)
())
Added: trunk/projects/bos/web/website-language.lisp
===================================================================
--- trunk/projects/bos/web/website-language.lisp (rev 0)
+++ trunk/projects/bos/web/website-language.lisp 2008-07-25 16:46:19 UTC (rev 3644)
@@ -0,0 +1,43 @@
+
+(in-package :bos.web)
+
+(enable-interpol-syntax)
+
+(define-persistent-class website-language ()
+ ((code :read :index-type string-unique-index :index-reader language-with-code)
+ (name :read :index-type string-unique-index)))
+
+(defun website-languages ()
+ (mapcar #'(lambda (language) (list (website-language-code language)
+ (website-language-name language)))
+ (class-instances 'website-language)))
+
+(defun website-supports-language (language)
+ (find language (website-languages) :test #'string-equal :key #'car))
+
+(defun language-from-url (path)
+ (register-groups-bind (language) (#?r"^/(..)/" path)
+ (when (website-supports-language language)
+ language)))
+
+(defun find-browser-prefered-language ()
+ "Determine the language prefered by the user, as determined by the Accept-Language header
+present in the HTTP request. Header decoding is done according to RFC2616, considering individual
+language preference weights."
+ (let ((accept-language (hunchentoot:header-in* :accept-language)))
+ (dolist (language (mapcar #'car
+ (sort (mapcar #'(lambda (language-spec-string)
+ (if (find #\; language-spec-string)
+ (destructuring-bind (language preference-string)
+ (split #?r" *; *q=" language-spec-string)
+ (cons language (read-from-string preference-string)))
+ (cons language-spec-string 1)))
+ (split #?r" *, *" accept-language))
+ #'> :key #'cdr)))
+ (when (website-supports-language language)
+ (return-from find-browser-prefered-language language))
+ (register-groups-bind (language variant) (#?r"^(.*)-(.*)$" language)
+ (declare (ignore variant))
+ (when (website-supports-language language)
+ (return-from find-browser-prefered-language language)))))
+ nil)
\ No newline at end of file
Modified: trunk/thirdparty/bordeaux-threads_0.4.0/src/cmu.lisp
===================================================================
--- trunk/thirdparty/bordeaux-threads_0.4.0/src/cmu.lisp 2008-07-25 16:24:06 UTC (rev 3643)
+++ trunk/thirdparty/bordeaux-threads_0.4.0/src/cmu.lisp 2008-07-25 16:46:19 UTC (rev 3644)
@@ -8,7 +8,7 @@
;;; Thread Creation
-(defun make-thread (function &key name)
+(defun make-thread (function &key (name "Anonymous"))
(mp:make-process function :name name))
(defun current-thread ()
More information about the Bknr-cvs
mailing list