;;; -*- Mode: LISP; Syntax: Common-lisp; Package: KBCLASSES; Base: 10. -*-

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;                                                                             ;
;  Copyright (c) 1988, 1995, 1999 by the University of Southern California    ;
;  All rights reserved.                                                       ;
;                                                                             ;
;  Permission to use, copy, modify, and distribute this software and its      ;
;  documentation in source and binary forms for non-commercial purposes       ;
;  and without fee is hereby granted, provided that this notice               ;
;  be reproduced in any copy or modification thereof, and that                ;
;  any documentation, advertising materials, and other materials related      ;
;  to such distribution and use acknowledge that the software was             ;
;  developed by the University of Southern California, Information            ;
;  Sciences Institute.  The name of the University may not be used to         ;
;  endorse or promote products derived from this software without             ;
;  specific prior written permission.                                         ;
;                                                                             ;
;  THE UNIVERSITY OF SOUTHERN CALIFORNIA MAKES NO REPRESENTATIONS ABOUT THE   ;
;  SUITABILITY OF THIS SOFTWARE FOR ANY PURPOSE.  THIS SOFTWARE IS PROVIDED   ;
;  "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING,          ;
;  WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND          ;
;  FITNESS FOR A PARTICULAR PURPOSE.                                          ;
;                                                                             ;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
;;; PREP.LISP (KBCLASSES)

;;; This file is the first of the KB-CLASSES files to be read --
;;;    it is compiled and loaded before any other files are processed.
;;; It defines some macros that are conceptually best considered as extensions
;;;    to Common Lisp.

(in-package "KBCLASSES")

(export '(grumble complain inform obsolete obsolete-argument))


  ;;
;;;;;; Convenient utility macros:
  ;;

(defmacro neq (x y) `(not (eq ,x ,y)) )

;;; Requiring the use of "if" to mean "if-then-else":
(defmacro if (test then &rest elseList)
  (when (null elseList)
    ;; if "elseList" is missing, warn against use unless we detect
    ;;    code indicating that some sort of macro expansion has
    ;;    generated the use of the "if":
     (unless (or (and (listp then)
		      (member (car then) '(let progn)))
		 (and (listp test)
		      (member (car test) '(progn))))
       (warn "LOOM requires the 'if' form to have an 'else' clause")))
  (when (cdr elseList)
    (error "LOOM requires the else part of an 'if' form to be a single form"))
  `(COMMON-LISP:if ,test ,then ,@elseList) )


  ;;
;;;;;; "integrity-check"
  ;;

(defmacro integrity-check (assertion &key message)
  ;; Generate an error if "assertion" is not true;
  ;; Replace this with a null body when speed becomes essential:
  `(or ,assertion
       (emit-integrity-check-warning
	 ',assertion ,message)) )

(defun emit-integrity-check-warning (assertion message)
  ;; Helping function for "integrity-check";
  ;; Generate an error message warning of an integrity check violation;
  (if message
      (cerror "Continue running LOOM""~S" message)
      (cerror "Continue running LOOM" "Integrity check violated -- not true that:~
                       ~%   ~S" assertion)) )

  ;;
;;;;;; For Loops
  ;;

;(defmacro for (&rest bodyOfFor)
;  (let ((keyword 
;	  (loop for k in '(collect append thereis)
;		thereis (find k bodyOfFor :test #'eq))))
;    (case keyword
;      ((collect append)
;       ;; code depends on "collect" or "append" being the last keyword
;       (setq bodyOfFor
;	     (loop for tail on bodyOfFor
;		   append
;		   (COMMON-LISP:if (eq (car tail) keyword)
;			  (prog1 `(,keyword (progn ,@(cdr tail)))
;			    (setq tail nil))
;			  (list (car tail))))))
;      (thereis
;       ;; code depends on "thereis" being the last keyword AND on the
;       ;;    iteration variable immediately succeeding the initial "for"
;       (setq bodyOfFor
;	     (loop for tail on bodyOfFor
;		   append
;		   (COMMON-LISP:if (eq (car tail) keyword)
;			  (prog1 `(,keyword (when (progn ,@(cdr tail))
;					      (return ,(car bodyOfFor))))
;			    (setq tail nil))
;			  (list (car tail)))))))
;    `(loop for ,@bodyOfFor) ))


  ;;
;;;;;; "once-only", "make-top-level-form"
  ;;

;;; "once-only" is borrowed from PCL, which borrowed it from Zeta-lisp
(defmacro once-only (arguments &body body)
  ;; Used to prevent multiple side-effects when an argument to a
  ;;    macro is evaluated;
  ;; For each argument in "arguments", if it is not atomic, wrap
  ;;    a "let" form around "body", assign the argument to a gensym
  ;;    variable, and substitute the gensym inside of "body"
  (let ((gensymVariable (gensym))
	(runTimeArgs (gensym))
	(runTimeValues (gensym))
	(expandTimeValueForms nil))
    (loop for var in arguments
	  do
	  (push
	    `(if (or (symbolp ,var)
		     (numberp ,var)
		     (and (listp ,var)
			  (member (car ,var) '(quote function))))
		 ,var 
		 (let ((,gensymVariable (gensym)))
		   (push ,gensymVariable ,runTimeArgs)
		   (push ,var ,runTimeValues)
		   ,gensymVariable))
	    expandTimeValueForms))
    `(let* (,runTimeArgs
	    ,runTimeValues
	    (wrappedBody
	      (let ,(loop for arg in arguments
			  as form in (reverse expandTimeValueForms)
			  collect (list arg form))
		,@body)))
       (if (loop for value in ,runTimeValues
		 always (or (symbolp value) (numberp value)))
	   ,@body
	   `(let ,(loop for arg in (reverse ,runTimeArgs)
			as value in (reverse ,runTimeValues)
			collect (list arg value))
	      ,wrappedBody))) ))


  ;;
;;;;;; Useful utility functions
  ;;

(defun string-append (&rest strings&symbols)
  ;; Return a string consisting of the concatenation of the members
  ;;    of "strings&symbols", where each member is coerced into a string
  (apply #'concatenate 'string
	 (loop for s in strings&symbols collect (string s))) )

(defmacro symbol-append ((&rest strings&symbols) packageName)
  ;; Return a symbol which is the concatenation of the atoms in
  ;;    "strings&symbols"
  (if (stringp packageName)
      `(intern (string-upcase (string-append ,@strings&symbols)) 
	       ,packageName)
      `(intern (string-upcase (string-append ,@strings&symbols)) 
	       (or ,packageName (package-name *package*)))))

#+(or :CLTL2 :ANSI-CL) (declaim (inline quoted-p))
#-(or :CLTL2 :ANSI-CL) (proclaim '(inline quoted-p))
(defun quoted-p (lispForm)
  ;; Return t iff "lispForm" is quoted;
  (and (consp lispForm)
       (eq (first lispForm) 'quote)) )

#+(or :CLTL2 :ANSI-CL) (declaim (inline function-p))
#-(or :CLTL2 :ANSI-CL) (proclaim '(inline function-p))
(defun function-p (lispForm)
  ;; Return t iff "lispForm" is a function expression;
  (or (typep lispForm 'FUNCTION)
      (and (consp lispForm)
	   (eq (first lispForm) 'function))) )

(defmacro push-last (item place)
  ;; Append "item" to the end of the list "place"
  `(setf ,place (nconc ,place (list ,item))) )

  ;;
;;;;;; Communication with users in unusual situations.
  ;;


(defmacro grumble (message &rest formatArgs)
  "Macro for producing formatted warning and error output using `WARN'."
  `(or (member :suppress-diehard-output LOOM::*loom-dialogue-features*)
       (warn ,message ,@formatArgs)) )

(defmacro complain (message &rest formatArgs)
  "Macro for producing formatted warning and error output."
  `(or (member :suppress-diehard-output LOOM::*loom-dialogue-features*)
       #+:cltl2(let ((*print-readably* nil))
		 (format *error-output* ,message ,@formatArgs))
       #-:cltl2(format *error-output* ,message ,@formatArgs)) )

(defmacro inform (message &rest formatArgs)
  "Macro for producing formatted information and trace output."
  `(or (member :suppress-diehard-output LOOM::*loom-dialogue-features*)
       #+:cltl2(let ((*print-readably* nil))
		 (format *trace-output* ,message ,@formatArgs))
       #-:cltl2(format *error-output* ,message ,@formatArgs)) )

(defmacro obsolete (name &optional newName)
  ;; Warns of obsolete usage;
  `(when (member :warn-about-syntax-corrections LOOM::*loom-dialogue-features*)
     (inform "~%~A is obsolete.~@[  Use ~A instead.~]"
             ',name ',newName)) )

(defmacro obsolete-argument (functionName oldArgument &optional newArgument
								transformFunction )
  ;; Warns of obsolete argument usage and performs a transformation to
  ;;   the new argument;
  `(when ,oldArgument
     (when (member :warn-about-syntax-corrections LOOM::*loom-dialogue-features*)
       (inform "~%Argument ~A to ~A is obsolete.~@[  Use ~A instead.~]"
               ',oldArgument ',functionName ',newArgument))
     ,@(when newArgument
         `((unless ,newArgument
             (setq ,newArgument
	       ,(if transformFunction
		    `(funcall ,transformFunction ,oldArgument)
		  oldArgument)))))) )

