;;; Copyright (c) 1999--2017 ;;; John Carroll, Ann Copestake, Robert Malouf, Stephan Oepen; ;;; see `LICENSE' for conditions. (in-package :lkb) #+:mswindows (unless (find-package "MAKE") (make-package "MAKE" :nicknames '("MK") :use '("COMMON-LISP"))) #+:mswindows (pushnew :lkb *features*) (defparameter *lkb-package* (or (find-package :lkb) (find-package :common-lisp-user))) ;;; if for some reason, the tty mode is desirable, use the following ;;; (pushnew :tty *features*) ;;; ;;; originally, the symbol `type' was used as a structure name; unfortunately, this is not ;;; permitted in ANSI CL so it was changed to ltype (= L[KB]type?). But before that change, ;;; the CL package was unlocked and remained so until 2020. This allowed developers to ;;; make unpermitted use of further symbols in the CL package. I'm finally calling a halt ;;; to this and commenting out this unlocking - JAC 16-May-2020 ;;; ; #+:allegro ; (setf excl:*enable-package-locked-errors* nil) ; ; #+:lispworks ; (setf hcl:*packages-for-warn-on-redefinition* ; (loop ; with key = (find-package :common-lisp) ; for name in hcl:*packages-for-warn-on-redefinition* ; for package = (find-package name) ; unless (eq key package) collect name)) ; ; #+:clisp ; (setf (ext:package-lock "LISP") nil) ; ; #+:sbcl ; (sb-ext:unlock-package :common-lisp) ; ; #+:ecl ; (si::package-lock "CL" nil) (defparameter *grammar-directory* ;; set and used in grammar `script' and globals.lsp files, conventionally holding ;; the `root' directory pathname of the grammar nil) #-:allegro (defparameter *initial-terminal-io* *terminal-io*) (defparameter *lkb-background-stream* #-:allegro *initial-terminal-io* #+:allegro excl::*initial-terminal-io*) (import '(enable-type-interactions disable-type-interactions)) #+(and :allegro :clim (not :mswindows) (not :64bit)) (setq tk-silica::*use-clim-gc-cursor* t) (defmacro with-package ((package) &body body) `(let ((*package* (find-package ,package)) (*read-eval* nil)) ; for safety ,@body)) (defun time-a-funcall (timed-function report-function) ;; ;; mimicry of an /old/ version of time-a-funcall() in Allegro CL. the report ;; function takes eight arguments: user and system gc() time, user and system ;; non-gc() time, wall-clock time, and allocation counts for cons() cells, ;; symbols, and other bytes. ;; #+(and :allegro-version>= (not (version>= 6 1))) (excl::time-a-funcall timed-function report-function) #+(and :allegro-version>= (version>= 6 1) (not (version>= 8 2))) (excl::time-a-funcall report-function timed-function) ;; ;; _fix_me_ ;; as of Allegro CL 8.2, timing is now in microseconds (surely a good thing, ;; in principle), and arguments to excl::time-a-funcall() have changed. ;; (17-aug-11; oe) #+(and :allegro-version>= (version>= 8 2)) (excl::time-a-funcall #'(lambda (stream tgcu tgcs tu ts tr scons sother static &rest ignore) (declare (ignore stream ignore)) (funcall report-function (round tgcu 1000) (round tgcs 1000) (round tu 1000) (round ts 1000) (round tr 1000) scons 0 (+ sother static))) *standard-output* timed-function) #-:allegro (flet ((gc-time () ;; in sbcl don't provide sb-ext:*gc-run-time* since it's already included ;; in the internal-run-time figure (or #+(or :mcl :ccl) (ccl:gctime) 0)) (bytes-allocated () (or #+(or :mcl :ccl) (ccl::total-bytes-allocated) #+:sbcl (sb-ext:get-bytes-consed) 0))) (let* ((treal (get-internal-real-time)) (tcpu (get-internal-run-time)) (tgc (gc-time)) (others (bytes-allocated))) (multiple-value-prog1 (funcall timed-function) (funcall report-function (round (* (- (gc-time) tgc) 1000) ; return in msecs internal-time-units-per-second) 0 (round (* (- (get-internal-run-time) tcpu) 1000) internal-time-units-per-second) 0 (round (* (- (get-internal-real-time) treal) 1000) internal-time-units-per-second) 0 0 (- (bytes-allocated) others)))))) (defun current-time (&key long) (decode-time (get-universal-time) :long long)) (defun decode-time (time &key long) (multiple-value-bind (second minute hour day month year foo bar baz) (decode-universal-time time) (declare (ignore foo bar baz)) (let ((months '("jan" "feb" "mar" "apr" "may" "jun" "jul" "aug" "sep" "oct" "nov" "dec"))) (cond ((null long) (format nil "~a-~a-~a" day month year)) ((member long '(:usa :us :reverse)) (format nil "~2,'0d-~2,'0d-~2,'0d" (mod year 100) month day)) ((member long '(:tsdb)) (format nil "~a-~a-~a ~2,'0d:~2,'0d" day (nth (- month 1) months) year hour minute)) ((member long '(:pretty :readable)) (format nil "~a-~a-~a (~2,'0d:~2,'0d h)" day (nth (- month 1) months) year hour minute)) ((eq long :short) (format nil "~2,'0d:~2,'0d:~2,'0d" hour minute second)) (t (format nil "~a-~a-~a (~2,'0d:~2,'0d:~2,'0d)" day month year hour minute second)))))) (defun normalize-string (string) (if string (loop with string = (if (stringp string) string (with-standard-io-syntax (let ((*package* (find-package :lkb))) (write-to-string string)))) with result = (make-array (length string) :element-type 'character :adjustable nil :fill-pointer 0) with space = t for c across string when (member c '(#\Space #\Newline #\Tab)) do (unless space (vector-push #\Space result) (setf space :space)) else do (vector-push c result) (setf space nil) finally (when (and (eq space :space) (not (zerop (fill-pointer result)))) (decf (fill-pointer result))) (return result)) "")) (defun start-lkb (&optional runtimep) ;; ;; if .runtimep. argument is true, we're cold-starting from a saved image, ;; in which case build-time absolute pathnames may well not be valid now; ;; therefore reset make::bin-dir et al. according to current image location ;; (assuming standard runtime directory structure). Also, if applicable ;; re-initialize [incr tsdb()] and reload ;; #+(or :allegro :sbcl :ccl) (when runtimep (let ((home #+:allegro (let ((sys (truename (translate-logical-pathname "sys:")))) (merge-pathnames (make-pathname :directory (butlast (pathname-directory sys))) sys)) #+(or :sbcl :ccl) (make-pathname :name nil :type nil :defaults #+:sbcl sb-ext:*core-pathname* #+:ccl ccl:*heap-image-name*))) (setf make::sys-home home) (make:reset-system-paths) #+:tsdb (funcall (find-symbol "INITIALIZE-TSDB" :tsdb) nil :action :all) #+(and :tsdb (or :bdb (and :allegro (or :linux :macosx)))) (dolist (lib '(#+:allegro "capi" #+:allegro "gc" #+:bdb "bdb")) (handler-case (#+:sbcl sb-alien:load-shared-object #-:sbcl load (make-pathname :name lib :type #-:macosx "so" #+:macosx "dylib" :defaults (dir-append (get-sources-dir "tsdb") (list :relative "tsdb" make::%system-binaries%)))) (error (condition) (warn "~A Is LD_LIBRARY_PATH correctly set?" condition)))))) ;; ;; load system initialization files (also in LOGON source tree if appropriate) ;; (loop for var in '("DELPHINHOME" #+:logon "LOGONROOT") for home = (getenv-directory var) for lkbrc = (and home (merge-pathnames (make-pathname :name "dot" :type "lkbrc") home)) do (when (and lkbrc (probe-file lkbrc)) (with-package (:lkb) (load lkbrc)))) ;; ;; load user's own `.lkbrc' initialization file if it exists ;; (let ((lkbrc (merge-pathnames (make-pathname :name ".lkbrc") (user-homedir-pathname)))) (when (probe-file lkbrc) (with-package (:lkb) (load lkbrc)))) #+:allegro (tpl:setq-default *package* (find-package :lkb)) ; JAC 15-May-2020 - disable SSP #-:allegro (setq *package* (find-package :lkb)) #+:lui (let* ((lui (make:getenv "LUI")) (port (and (stringp lui) (> (length lui) 0) (parse-integer lui :junk-allowed t)))) (when lui (lui-initialize :port port :runtimep runtimep :lui lui))) ;; ;; start up GUI unless :tty specified ;; #-:tty (let ((display #+:clim (make:getenv "DISPLAY") #-:clim nil) ;; (*package* (find-package #+:clim :clim-user #-:clim :lkb)) ; *** ) (when #+:mswindows t #-:mswindows (and (stringp display) (not (string= display ""))) #+:clim (clim-user::set-up-lkb-interaction) #-:clim (lkb::set-up-lkb-interaction)) ;; ;; _fix_me_ ;; attempt to work around [spr31047], i.e. what appears to be an ;; invalid function pointer added by the top-level CLIM pane. ;; (23-jan-06; oe) ;; #+(and :allegro :64bit) ;; (setf (excl:gc-before-c-hooks) nil (excl:gc-after-c-hooks) nil) )) ;;; Under ANSI spec, application of defconstant multiple times is undefined ;;; unless values are eql. SBCL treats this undefined behaviour as an error. ;;; Note that (as permitted by the spec) SBCL evaluates the value at both ;;; compile time and load time. (defmacro define-constant (name value &optional doc) `(defconstant ,name (if (boundp ',name) (symbol-value ',name) ,value) ,@(when doc (list doc))))