;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;                                                          ;;;;;;;;
;;;;;;  All files in this directory or any subdirectories are   ;;;;;;;;
;;;;;;  copyright 1997, 1998, 1999, 2000, 2002, 2003.           ;;;;;;;;
;;;;;;  by Rafael D. Sorkin.  All rights reserved.              ;;;;;;;;
;;;;;;                                                          ;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;  bibliotek.gcl.l    Time-stamp:< 2003-Dec-06 21:03:37 16338.35449 >

;; THIS VERSION IS SPECIFIC TO GCL (Gnu Common Lisp)

;; Load this file AFTER bibliotek.TCL

;; This is loaded BEFORE bibliotek.macros.l so don't use eg `deff' here

;: Roster of functions, macros, aliases, and types defined herein
;
; load-safe
; stop-loading/stop
; garbage-collect (function)
; loop (alias for sloop:sloop)
; lambda (macro)
; memq 
; delq
; natnum  (type)
; fixpos  (type)
; sequencep 
; natnump  


;: Set up some aliases

;; The first one should work, but use second if desparate:

(defalias 'loop 'sloop:sloop)

 ;(defmacro loop (&rest H) (cons 'sloop:sloop H))


;: Define some functions (mostly taken from elisp)

(defun garbage-collect () "do a full garbage collection" (gbc t))

(defun memq (elt list) 
  " Like `member' but with test being `eq'"
  (member elt list :test 'eq))

(defun delq (elt list)
  " Like `delete' but with test being `eq'"
  (delete elt list :test 'eq))

;;; Here we try to inline memq and delq
 ;  Also could do the same for other small fcns
 ;
 ; It doesn't seem to do any harm, and might have helped in fact.
 ; Must check correct syntax for this, however!  
 ; Once we have it, can prob use `defsubst' instead

(declaim (inline memq delq)) 


;; Next three are for `load-safe'

(defun stop-loading (&rest H)
  (si:universal-error-handler :loaded nil 'stop-loading "" "" H))

(defalias 'stop 'stop-loading)

 (defmacro restore-error-handler () 
  `(setf (symbol-function 'si:universal-error-handler) saved-handler))
  ;
  ; should incorporate this into next

(defun load-safe (filename)
  (let ((saved-handler (symbol-function 'si:universal-error-handler))
	(file-not-found nil)
	(args nil)
	(msg nil))
  (unwind-protect
  (progn
   ;--------------------------------
   ;/kila kitu happens in this block
   ;--------------------------------
    (block moja
      (setf
       (symbol-function 'si:universal-error-handler) 
       (lambda (a1 a2 a3 a4 a5 &rest fmt-args)
	 (setq args (list* a1 a2 a3 a4 a5 fmt-args))
	 (restore-error-handler)
	 (return-from moja)))
      (setq args nil)
      (unless
	(load (concat *lisp-home* filename) :if-does-not-exist nil :print nil)
	(setq file-not-found t)))
   ;--------------------------------------------------------------
   ;/now we do interrupt the loading if a genuine problem occurred
   ;--------------------------------------------------------------
    (restore-error-handler)
    (cond
    ;--------------------------
    ;/case where file not found
    ;--------------------------
     (file-not-found 
       (princ (symbol-function 'si:universal-error-handler))
       (si:universal-error-handler 
	 :error nil 'load-safe "" "~&The file ~s wasn't found" filename))
    ;----------------------------------------
    ;/case where whole file was loaded to end
    ;----------------------------------------
     ((not args) t)
      ;; ((not args) (princ "load proceeded to eof") t)
    ;--------------------------------------------------------
    ;/case where loading stopped by embedded stop instruction
    ;--------------------------------------------------------
     ((eq (caddr args) 'stop-loading) 
      (setq msg (nth 5 args))
      (cond
       (msg (format t "~&~s ~&" msg))
       (t (format t "~&Loaded up to the stop instruction: ~s ~&" filename)))
      t)
    ;----------------------------------
    ;/case where genuine error occurred
    ;----------------------------------
     (else (apply #'si:universal-error-handler args))))
 ;------------------------------------------------------------------
 ;/the "unwind forms" (they function even if some disaster happened
 ;------------------------------------------------------------------
  (restore-error-handler)
  "unwound")))
  ;
  ; The keyword :print tells it to print the results of all evaluations or
  ; something.


;: Define some types and type predicates

(deftype natnum () " the type of the nonnegative integers" '(integer 0 *))

(deftype fixpos () 
  " The name means the positive subset of fixnums."
  `(mod ,most-positive-fixnum))
  ;
  ; (mod n) is a type the gcl compiler recognizes, it's realy a misnomer,
  ; since the set is not closed under arithmetic operations.


(defun sequencep (x) " Is this object of the `sequence' type?"
  (typep x 'sequence))
  ;
  ; In gcl the type `sequence' exists, but not the function `sequencep'

(defun natnump (n) " Is this a non-negative integer?" 
  (and (integerp n) (>= n 0)))
  ;
  ; this type is not pre-defined at all in gcl
  ;
 ;; we could also recode `natnump' a la `sequencep'


;: Make `lambda' a macro

;; maybe not needed now, try again

; (defmacro lambda (&rest args-forms) 
;   "\
;  Defining `lambda' as this macro will make lambda expressions evaluate to
;  functions--as they do in elisp--rather than lists.
;   "  
;   (list 'function (cons 'lambda args-forms)))

;; Do we really need this in gcl? yes as of version 2.3 (2001 Sep 4)

;:  e n d