Switch branches/tags
Nothing to show
Find file
Fetching contributors…
Cannot retrieve contributors at this time
216 lines (171 sloc) 6.63 KB
;;; 2010-02-08 janderson
;;; a dev build template
;;; it locates an asdf and the hierarchic system name extension in the tree
;;; (see
(in-package :cl-user)
;; universal comment-reader
(defun |universal-comment-reader| (stream char)
(declare (ignore char))
(loop (case (read-char stream nil nil)
((#\return #\linefeed nil) (return))
(t )))
#-abcl ; the abcl reader does not do (values) correctly
(set-macro-character #\; '|universal-comment-reader|)
(shadow '(#:save-image #:save-system #:load-system #:leave-lisp #:print-backtrace) :cl-user)
(setq ext:*gc-verbose* nil)
(setq *load-verbose* (setq *compile-verbose* t))
(defparameter *build-init-pathname*
(or *load-pathname*
(error "Indeterminate load pathname...")))
(setq *build-init-pathname* (truename *build-init-pathname*))
(when *load-verbose*
(format *trace-output* "~%;Build root: ~s." *build-init-pathname*))
;;; load the production asdf version for building images
;;; in a dev tree, this mens to go upwards to look for the production tree
(defparameter *asdf-pathname*
(make-pathname :directory (if (find "dev" (pathname-directory *build-init-pathname*)
:test #'string-equal)
(append (butlast (pathname-directory *build-init-pathname*) 2)
'("production" "Library" "net" "common-lisp" "asdf"))
(append (pathname-directory *build-init-pathname*)
;; '("net" "common-lisp" "asdf")))
'("net" "common-lisp" "asdf-logical")))
:name "asdf" :type "lisp"
:defaults *build-init-pathname*))
(unless (let (#+allegro (excl::*AUTOLOAD-PACKAGE-NAME-ALIST* nil))
(find-package :asdf))
(when *load-verbose*
(format *trace-output* "~&;Incorporating asdf anew from ~s." *asdf-pathname*))
(load (compile-file *asdf-pathname*))
(load (compile-file (make-pathname :name "asdf-ecl" :defaults *asdf-pathname*))))
;; debugging clisp (trace make-pathname)
;;; bulding the analysis system itelf requires locating lots of systems in the dev tree
;;; include when intended to support de.setf library builds
#+(or :ccl :allegro :sbcl)
(unless (fboundp (find-symbol (string :sysdef-hierarchical-search-function) :asdf))
(load (make-pathname :directory (append (pathname-directory *build-init-pathname*)
'("de" "setf" "utility" "asdf"))
:name "hierarchical-names" :type "lisp"
:defaults *build-init-pathname*)))
;;; search first the dev sources, then production
;;; in order to load module cross-references, dedicated registration
;;; are unavoidable - check them last, in order that hierarchic system
;;; designators be generated as nicknames
(map nil
#'(lambda (pathname)
(setf pathname (make-pathname :name nil :type nil :defaults pathname))
(when (#-clisp probe-file #+clisp probe-directory pathname)
(pushnew (truename pathname) asdf:*central-registry* :test #'equalp)))
(list (make-pathname :directory (append (pathname-directory *build-init-pathname*)
:defaults *build-init-pathname*)
;;; from asdf/test/script-support.lisp
(defun leave-lisp (&optional message (return 0))
(when message
(format *error-output* message))
(ext:quit :status return)
(excl:exit return)
(ext:quit return)
#+(or cmu scl)
(unix:unix-exit return)
(si:quit return)
(lisp:quit return)
(lispworks:quit :status return :confirm nil :return nil :ignore-errors-p t)
#+(or openmcl mcl)
(ccl::quit return)
(sb-ext:quit :unix-status return)
(error "Don't know how to quit Lisp; wanting to use exit code ~a" return))
(defun save-image (pathname &optional system)
(when *load-verbose*
(format *trace-output* "~&saving ~@[~a ~] image to ~a." system pathname))
(warn "cannot save images.")
(excl:dumplisp :name pathname)
(ccl:save-application pathname)
(ext:saveinitmem pathname)
(extensions:save-lisp pathname :load-init-file nil :site-init nil)
(asdf:make-build system :type :fasl :monolithic t :move-here pathname)
;; still need to copy the file once it is found
(warn "cannot save images.")
(sb-ext:save-lisp-and-die pathname)
(defun save-system (&rest args) (apply #'save-image args))
(defun print-backtrace (&optional (stream *standard-output*))
(format stream "~&~{ ~a~%~}" (system:backtrace))
(let ((*terminal-io* stream))
(tpl::zoom-print-stack nil nil))
(let ((ccl::*debug-io* stream))
(ccl::print-call-history :process *current-process* :start-frame-number 0 :detailed-p t))
(system::print-backtrace :out stream :limit most-positive-fixnum)
(debug:backtrace most-positive-fixnum stream)
(let ((*standard-output* stream))
(dbg::output-backtrace :bug-form stream)
(sb-debug:backtrace most-positive-fixnum stream)
(defun load-system (system)
(handler-case (asdf:load-system system)
(error (c)
(warn "Build (~a) failed with error: ~a." system c)
(cl-user::leave-lisp "Build failed" 255))))
;;; cl-ppcre
;;; clx
cd /development/source/library/org/cl-http
ccl --no-init --load /development/source/library/build-init.lisp \
--eval "(asdf:load-system"
(http::set-local-context "http://ip-10-251-70-19.ec2.internal:8082")
;; no! this does not set the context
;;(http::start-serving "ip-10-251-70-19.ec2.internal" 8082 :type :single)
;; locally
(http::start :hostname "" :port 8082 :type :not-yet)
;; (http::local-context)
;; ""
(http::start-serving "" 8082 :type :stupid-multi)
> Error: value NIL is not of the expected type STRING.
implies the:
1 > (http::local-context)
1 >
;;; de.setf.documentation
(load "/Development/Source/dev/Library/de/setf/utility/asdf/hierarchical-names.lisp")
(asdf:load-system :de.setf.documentation)