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 ()