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