(in-package "KPML")

;;; File: macro-utilities.lisp
;;; 

;;; ----------------------------------------------------------------------
;;; Following eases writing knowledge base interface functions where
;;; the symbols referred to should be interned in the appropriate
;;; knowledge base package.

(defmacro WITH-KB-PACKAGED-VARS ((&rest var-list) &body body)
  `(let ,(loop for var in var-list
	      collect `(,var (find-symbol (symbol-name ,var) (kb-package))))
     ,@body))

;;; ----------------------------------------------------------------------
;;; Following is a John Wilkinson patch for speed; replaces the
;;; CLISP macro of the same name...

; concat used concatlist which is very slow; this is far better.
; defined as a function rather than a macro because it can be loaded without
; recompiling penman this way.
; John: Stirling: Sep97 eval removed for standalones...
(defun CONCAT (&rest args)
;; was:    (eval (concatenate 'list '(concatenate 'string) args))
;; now:
  (apply 'concatenate (cons 'string args)))

;;; ----------------------------------------------------------------------
;;; The rest are  mostly very old Penman macros taken over here...

(defmacro add-to-blackboard (x)
  "previously Add-It"  
  `(push ,x blackboard))

(defmacro delete-from-blackboard (x)
  "previously Delete"
  `(setq blackboard (DREMOVE ,x blackboard)))

(defmacro nigel-nlistp (x)
  ;;;nlistp is a function in TI lisp which acts differently
  `(not (listp ,x)))

(defmacro add-atoms-to-assoc (key atoms assoclist)
  "given a key it adds atoms to that keys cdr in assoclist"
  `(if (assoc ,key ,assoclist)
       (rplacd (assoc ,key ,assoclist) 
	       (union (mklist ,atoms)
		      (mklist (cdr (assoc ,key ,assoclist)))))
     (push (append (mklist ,key) (mklist ,atoms))
	   ,assoclist)))

(defmacro add-list-to-assoc (key lst assoclist)
  `(if (assoc ,key ,assoclist)
       (rplacd (assoc ,key ,assoclist) 
	       (cons ,lst (cdr (assoc ,key ,assoclist))))
       (push (list ,key ,lst) ,assoclist)))

(defmacro first-or-nil (arg)
  "returns car of form if list else returns nil, like interlisp car"
  `(if (listp ,arg)
       (car ,arg)
       nil))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;macros from sgchoice
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(DEFMACRO Chooser-Item-Body (&REST Chooser-Body)
  (cdr chooser-body))

(DEFMACRO Set-Mode (VAL OPN)
  `(set-mode-1 ',VAL ',OPN))

;;; ----------------------------------------------------------------------

(defmacro branching-inquiry-p (op)
  `(fetch-inquiry-info ,op 'answerset))

(defmacro identifying-inquiry-p (op)
  `(not (fetch-inquiry-info ,op 'answerset)))

;;; ----------------------------------------------------------------------
;;; 3.1 font and character set support for PCs...
;;; 4.0 problem is that the more advanced and varied character settings
;;;     mess up the normal Lisp Listener and Editor windows with 
;;;     Lispworks. The font becomes a proportional font which these
;;;     windows apparent cannot deal with (under LWW4.1.19 at least).
;;;     This detracts a lot from ease of development, so we make these
;;;     code page settings rather more conditionalized: they are then
;;;     not the default mode of use for KPML. An additional flag (whoopie...
;;;     yes *another* one, after the first 1000 why not another?...)
;;;     turns this behaviour on and off. The easiest way of controlling
;;;     this is to make sure that the function code-page-for-lg
;;;     never returns a non-NIL value. This is managed with a change
;;;     in code-page-setter.lisp
;;;     4.0b but still need to make sure that we are only dealing
;;;          with PCs!
;;; ----------------------------------------------------------------------

(defmacro WITH-CODE-PAGE-SETTINGS ((lg) &body body)
  #+(and lispworks win32)
  `(let* ((code-page (kpml::code-page-for-lg ,lg)))
     (if code-page
	 (let ((win32::*multibyte-code-page-ef* 
		(list 'win32::code-page :id code-page))
	       (sys:*file-encoding-detection-algorithm* 
		(list #'(lambda (&rest args) 
			  (declare (ignore args))
			  `(win32:code-page :id ,code-page)))))
	   (declare 
	    (special sys:*file-encoding-detection-algorithm* 
		     win32::*multibyte-code-page-ef*))
	   (kpml::set-code-page-settings ,lg)
	   ,@body)
       (progn
	 ,@body)))
  #-(and lispworks win32)
  `(progn
     ,@body))


;;; ----------------------------------------------------------------------
;;; 3.2  macro for making the grammatical->lexical feature mappers
;;;      not quite so ugly...
;;; ----------------------------------------------------------------------

(defmacro FEATURE-SET-CASE (var &body conditions)
  `(cond 
    ,@(loop for c in conditions
	    collect `((set-equal ,var ',(car c)) ,@(cdr c)))))

