;;; -*- Mode: LISP; Package: USER; Base: 10 -*-
;;; $Header: /ct/debug/dbutils.l,v 1.10 84/09/27 11:59:19 bill Exp $
(putprop 'dbutils "$Revision: 1.10 $" 'rcs_revision)
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;                                                                  ;;;
;;;                            dbutils.l 			     ;;;
;;;                                                                  ;;;
;;; William Brew                                        10-29-83     ;;;
;;;                                                                  ;;;
;;;                                                                  ;;;
;;;                                                                  ;;;
;;; This file is part of a proprietary software project.  Source     ;;;
;;; code and documentation describing implementation details are     ;;;
;;; available on a confidential, non-disclosure basis only.  These   ;;;
;;; materials, including this file in particular, are trade secrets  ;;;
;;; of Computer * Thought Corporation.                               ;;;
;;;                                                                  ;;;
;;; (c) Copyright 1982 and 1983,  Computer * Thought Corporation.    ;;;
;;;     All Rights Reserved.                                         ;;;
;;;                                                                  ;;;
;;; Reference materials:                                             ;;;
;;;   Foderaro and Sklower, The FRANZ LISP Manual, September 1981.   ;;;
;;;   Weinreb and Moon, LISP MACHINE MANUAL, Symbolics, July 1981.   ;;;
;;;   Charniak et al., 1980.  Artificial Intelligence Programming.   ;;;
;;;   Miller, 1982.  The C*T Ada Tutor: Guide to the Implementation. ;;;
;;;                                                                  ;;;
;;;   The following code assumes familiarity with these materials.   ;;;
;;;                                                                  ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Ensure presence of needed files. 

(comment Assumes ct_load and some suitable file_map are present)

(eval-when (compile load eval) (ct_load 'aip))	   ;AIP macros pkg. 

(eval-when (compile load eval) (ct_load 'compat))  ;Franz/LM compat pkg.

(eval-when (compile load eval) (ct_load 'ctstrl))  ;New strings

(eval-when (compile load eval) (ct_load 'ctio))    ;Compatable io

(eval-when (compile load eval) (ct_load 'ctflav))  ;Compatable flavors

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Compiler Declarations and Global Variables -- 

#+franz (declare (macros t))
#+franz (setq *flavor-expand-macros* t)

(declare (special *db%user_window* *display-inhibited*))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Macro definitions --

;
; If you want redisplay inhibited for a time, use this macro.
; It will bind *display-inhibited* preventing any redisplay
; calculations.
;

(defmacro with-output-buffered (stream &body body)
  `(unwind-protect
     (let ((*display-inhibited* t))
       ,@body)
     (ct_if (and ,stream
		 (instancep ,stream)
		 (eq (#+franz flavor #+lispm typep ,stream)
		     'db%debug_window))
	    (ct_send ,stream ':display-page)
	    #+franz(drain ,stream))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Flavor definitions --

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Externally Callable Functions/Methods -- 

; 
; Initialize the debugger utilities module
; 

(defun db%init_dbutils ()
    nil
)

; 
; Startup the debugger utilities module.
; 

(defun db%start_dbutils ()
    nil
)

; 
; Some utilities for the debugger.
; 

; 
; A function to write out a message in the user interaction window. Takes
; arguments like format.
; 

(defun db%message (ctrl-string &rest args)
    (with-output-buffered *db%user_window*
	(apply (function ct_format)
	       (cons *db%user_window* (cons ctrl-string args)))
	(ct_terpri *db%user_window*)))

;;;Call this if you have a very bad error and are about to leave.
#+lispm
(defun db%ctada_error (error_string)
  (send terminal-io ':home-cursor)
  (send terminal-io #+Symbolics ':clear-rest-of-line #-Symbolics :clear-eol)
  (send terminal-io ':home-cursor)
  (format t "~A ~%" error_string)
  (beep))

#+franz
(defun db%ctada_error (error_string)
  (lose 'db%ctada_error 'db%ctada_error (list error_string)))

; 
; Try to protect from file or directory errors during probef
; 

#+lispm
(defun db%probef (filename)
  (condition-case ()
      (probef filename)
    (sys:network-error nil)
    (fs:data-error  nil)
    (fs:file-lookup-error nil)
    (fs:link-target-not-found nil)
    (fs:access-error nil)
    (fs:invalid-pathname-syntax nil)
    (fs:pathname-error nil)
    (fs:wrong-kind-of-file nil)
    (fs:creation-failure nil)
    (fs:no-more-room nil)
    (fs:not-available nil)))


#+franz
(defun db%probef (filename)
    (probef filename))

;
; Probe for a directory
;

#+lispm
(defun db%probedir (filename)
  ;;Check to make sure that the given filename uses a valid
  ;;path
  (condition-case ()
	(probef filename)
#|
    (sys:network-error  "File System Denying Services")
    (fs:data-error  "File System Denying Services")
    (fs:device-not-found  "Illegal Device")
    (fs:directory-not-found  "Directory Pathname Error")
    (fs:link-target-not-found "File System Error")
    (fs:invalid-pathname-syntax  "Invalid Pathname Syntax")
    (fs:pathname-error   "Invalid Pathname Syntax")
    (fs:wrong-kind-of-file  "Wrong Kind of File")
    (fs:creation-failure  "File Creation Failure")
    (fs:no-more-room  "File System Full")
    (fs:not-available "File/Device not available.  See operator")
    (fs:file-locked "File is Locked")
    (fs:file-lookup-error "File Not Found")
    (fs:file-open-for-output "File Already Open for Output")
    (fs:file-error "File Pathname Error")
    (fs:file-request-failure "File System Error")
    (fs:file-operation-failure "File Pathname Error")
|#
    (error nil)
    (:no-error t)))

#+franz
(defun db%probedir (filename)
  (db%probef filename))

; 
; A function to get the proper article for putting before the print representation
; of thing. Coerce thing to a string. Look at the first character. If a vowel then
; use "an". Otherwise use "a".
; 

(defun db%proper_article_for (thing)
    (ct_string_article (db%coerce_to_string thing))
)

; 
; Try running a hooked function. If there is a simple hook and it looks
; like a function, then apply it to the args. If there is a list and the car
; is a function, then apply it to the args and the cdr of the list.
; 

(defun db%maybe_run_hook (hook &rest arg_list)
    (cond ((null hook) nil)
	  ((db%funcp hook)
	   (car (errset (apply hook arg_list) nil))
	  )
	  ((and (listp hook) (db%funcp (car hook)))
	   (car (errset (apply (car hook) (append arg_list (cdr hook))) nil))
	  )
    )
)


; 
; A predicate to check to see if something looks like a function.
; 

(defun db%funcp (thing)
    (and (symbolp thing) (#+franz getd #+lispm fboundp thing))
)

; 
; A function which tries some simple schemes to coerce a thing to a string.
; First, if nil then return "". If a string then return it. If a symbol then
; return its print name. If a form like thing then try applying it. Otherwise
; return "".
; 
; --NB something like this should probably be moved to the string package
(defun db%coerce_to_string (thing)
    (cond ((null thing) "")
	  ((stringp thing) thing)
	  ((symbolp thing) (ct_string thing))
	  ((numberp thing) (ct_format nil "~a" thing))
	  ((db%coerce_to_string (db%maybe_run_hook thing)))
	  (t "")
    )
)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Internal Use Only Functions/Methods -- 

;;; eof
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;