;;; -*- Mode:Lisp; Package:DYPAR; Base:10; -*-

;;;		  LastEditDate =  13:20:42  Sun, 09-Apr-89  -- Mark Boggs

;;; ----------------------------------------------------------------
;;;
;;; 		(c) Copyright, 1982,
;;; 			by Mark Boggs and Stephen Morrisson
;;; 			All rights reserved
;;;
;;; ----------------------------------------------------------------

;;; MACROS.LSP

;;; Generic extension routines for LISP.  These are, for the most part,
;;; commonly used routines that should probably be defined in C by the
;;; people at Berkeley.  But, they're not so here goes.

;;; Each of the functions is preceded by a comment which is the form of
;;; the expansion for that macro.

;;; HISTORY
; 09-Apr-89  Mark Boggs (boggs) at Rank Xerox, Spain
;	Changed definitions for new-nonterms/pattrans/patrules macros.
;
; 15-Jan-89  Mark Boggs (boggs) at Rank Xerox, Spain
;	Reworked for Common Lisp Dypar, adding package support.
;
; 14-Jan-89  Mark Boggs (boggs) at Rank Xerox, Spain
;	Converted for GCL3.1
;	Changed memq to memb (just a call to member)
;	Changed putprop to ptprop because GCL does it different.
;	Added is-boundp which seems to have gotten lost somewhere.
;		might need to list the result as I don't remember what
;		value Franz lisp returned from boundp.
;	#+ syntax usage eliminated because it doesn't work in GCL
;
; 24-Aug-84  Scott A. Safier (ss) at Carnegie-Mellon University
;	Added changes for conversion to Common Lisp. #+ syntax used to
;       distinguish between various lisp forms
;

;;; Create the Dypar package if it hasn't already happened.

(if (not (find-package "DYPAR"))
    (make-package "DYPAR" :use '("LISP" "USER")))

(in-package "DYPAR")

(proclaim '(special !ptrace !!dbg!! $outport$))

(defmacro putd (new-name definition)
    `(setf (symbol-function ,new-name) ,definition))

(defmacro getd (name) `(symbol-function ,name))

(defmacro strlen (arg)
    (let ((g (gensym)))
	 `(let ((,g ,arg))
	       (etypecase ,g
		   (string (length ,g))
		   (symbol (length (symbol-name ,g)))
		   (number (length (princ-to-string ,g)))
		   (list (length (princ-to-string ,g)))))))

;;; (function (lambda form))
(defmacro funl (&rest form)
    `(function (lambda ,@form)))

;;; (and !!dbg!! (msg form))
(defmacro dbg! (&rest form)
    `(and !!dbg!!
	  (progn (format t ,@form)
		 t)))

;;; (and !ptrace (msg form))
(defmacro ptrace (&rest form)
    `(and !ptrace
	  (progn (format t ,@form)
		 t)))

;;; (nconc a (list b))
(defmacro nconc1 (a b)
    `(nconc ,a (list ,b)))

;;; (cond ((atom a) a)
;;;	  (t (cadr a)))
(defmacro acr (x)
    `(let ((a ,x))
	  (cond ((atom a) a)
		(t (cadr a)))))

;;; (cond ((lessp x y) y))
(defmacro *less (x y)
    `(cond ((lessp ,x ,y)
	    ,y)))

;;; (cond ((> x y) y))
(defmacro *great (x y)
    `(cond ((greaterp ,x ,y)
	    ,y)))

;;; (not (equal a b))
(defmacro nequal (a b)
    `(not (equal ,a ,b)))

;;; (not (greaterp a b))
(defmacro leq (a b)
    `(not (greaterp ,a ,b)))

;;; (not (lessp a b))
(defmacro geq (a b)
    `(not (lessp ,a ,b)))

;;; (and (atom a) (not (numberp a)))
(defmacro litatom (a)
    `(and (atom ,a)
	  (not (numberp ,a))))

;;; (or (and a (cons a b))
;;;     b)
(defmacro consn (a b)
    `(or (and ,a
	      (cons ,a ,b))
	 ,b))

;;; (cond ((atom a) (list a))
;;;	  (t a))
(defmacro manyfy (a)
    `(cond ((atom ,a) (list ,a))
	   (t ,a)))

;;; (list (list form))
(defmacro list2 (&rest form)
    `(list (list ,@form)))

;;; (putprop a (cons b (get a c)) c)
(defmacro putget (a b c)
    `(setf
	 (get ,a ,c)
	 (cons ,b (get ,a ,c))))

;;; (putprop a (condense (cons b (get a c))) c)
(defmacro cputget (a b c)
    `(setf
	 (get ,a ,c)
	 (condense (cons ,b (get ,a ,c)))))

;;; (setq a (cdr a))
(defmacro setqcdr (a)
    `(setq ,a (cdr ,a)))

;;; (setq b (cons a b))
(defmacro setcons (a b)
    `(setq ,b (cons ,a ,b)))

(defmacro setnconc (a b)
    `(setq ,b (nconc ,a ,b)))

(defmacro setnconc1 (a b)
    `(setq ,b (nconc1 ,a ,b)))

(defmacro *setnconc1 (a b)
    `(setq ,a (nconc1 ,a ,b)))

(defmacro setappend (a b)
    `(setq ,b (append ,a ,b)))

;;; In LISP the function some should be defined as a macro.  In Franz this
;;; is not the case!  (We did it here at CMU)  But, for our purposes, we
;;; will make some into a macro again, and also reverse the argument order,
;;; to make it correspond with UCI syntax.
;;; usage:  (uci-some 'function 'list)
;;; The first time function returns a non-nil result, the function will
;;; exit returning the current tail of the list.  If no evaluations of
;;; (function (caxr list)) returns a non-nil value the value returned by
;;; some is nil.

(defmacro uci-some (fnc lst)
    `(do ((l ,lst (cdr l)))
	 ((null l) nil)
	 (and (funcall ,fnc (car l))
	      (return l))))

;;; uci-someval is the same as some, except it returns the value of the first
;;; successful function call or nil.

(putd 'uci-someval (getd 'some))

;;;; MACROS used for the new loader used with the new cross-referencer

(defmacro concat (&rest args)
    `(intern (string-upcase (concatenate 'string
			      ,@(mapcar #'(lambda (x)
					    `(princ-to-string ,x))
				  args)))))

;;; These just return the symbol used for storing each rule type. The symbol 
;;; is a function of the file that is being read in.

(defmacro new-patrules (file)
  `(symbol-value (concat (pathname-name ,file) "-RULES")))

(defmacro new-pattrans (file)
  `(symbol-value (concat (pathname-name ,file) "-TRANS")))

(defmacro new-nonterms (file)
  `(symbol-value (concat (pathname-name ,file) "-NONTERMS")))

(defmacro cons-end (l x)
    `(append ,l (list ,x)))

(defmacro caratom (x) 
    `(cond ((atom ,x) ,x)
	   (t (car ,x))))

(defmacro condense (l) `(remove-duplicates ,l :test #'equal))
(putd 'quick-union (getd 'union))
(putd 'set-union (getd 'quick-union))
;#+ common (defmacro union (x y) `(quick-union ,x ,y :test #'equal))
(putd 'quick-intersect (getd 'intersection))
;#+ common (defmacro intersection (x y) `(quick-intersect ,x ,y :test #'equal))
;;(putd 'ascii (getd 'integer))

;;; GCL defines this to return the symbol which owns the property. SO we
;;; change putprop's name to ptprop. Yecch!!
(defmacro ptprop (x y z) `(setf (get ,x ,z) ,y))

(putd 'memb (getd 'member))
;#+ common (defmacro member (a b) `(memb ,a ,b :test #'equal))
(defmacro getcharn (sym id)
	      `(char-int (char (symbol-name ,sym) (1- ,id))))
(defmacro implode (lst)
	      `(intern (concatenate 'string
			   (mapcar #'(lambda (ch)
					     (etypecase ch
						 (character ch)
						 (symbol (char (symbol-name
								    ch) 1))
						 (fixnum (code-char ch))))
				   ,lst))))
(defmacro for-each (var val &body body)
	      `(dolist (,var ,val) ,@body))

(defmacro msg$ (argl)
    `(for-each elt ',argl
	(cond
	    ((eql elt t)
		(terpri))
	    (t (msg (eval elt))))))

;;; Define properties.   <list> ::= (pname att1 val1 att2 val2 ...)

(defmacro dps (lst)
    `(do ((name (car ',lst))
	 (l (cdr ',lst) (cddr l)))
	((null l) name)
	(setf (get name (car l)) (cadr l))))


;;; plst = (propname propval atm1 atm2 atm3 ...)
;;; puts the same property on a list of atoms.

(defmacro dsameprop (plst)
    `(do ((pname (car ',plst))
	 (pval (cadr ',plst))
	 (l (cddr ',plst) (cdr l)))
	((null l) ',plst)
	(setf (get (car l) pname) pval)))

;--- msg : print a message consisting of strings and values
; arguments are:
;   N	    - print a newline
;   (N foo) - print foo newlines (foo is evaluated)
;   B       - print a blank
;   (B foo) - print foo blanks (foo is evaluated)
;   (P foo) - print following args to port foo (foo is evaluated)
;   (C foo) - go to column foo (foo is evaluated)
;   (T n)   - print n tabs
;   D	    - drain
;   other   - evaluate a princ the result (remember strings eval to themselves)
(defmacro msg (&rest msglist)
  (do ((ll msglist (cdr ll))
       (result)
       (cur nil nil)
       (current))
      ((null ll) `(progn ,@(nreverse result)))
      (setq current (car ll))
      (cond ((consp current)
	     (case (car current) 
		   (n (setq cur `(msg-tyo-char 10 ,(cadr current))))
		   (B (setq cur `(msg-tyo-char 32 ,(cadr current))))
;		   (T (setq cur `(msg-tyo-char #\tab ,(cadr current))))
		   (C (setq cur `(tab (1- ,(cadr current)))))
		   (t (setq cur `(msg-print ,current)))))
	    ((eql current 'N) (setq cur (list 'terpr)))
	    ((eql current 'B) (setq cur (list 'tyo 32)))
	    ((eql current 'D) (setq cur '(force-output)))
	    (t (setq cur `(msg-print ,current))))
      (If cur 
	  (setq result (cons cur result)))))

(defmacro tyo (int) `(princ (code-char ,int)))

(defun tab (int) (declare (ignore int)) t)

(defun msg-tyo-char (ch n)
  (do ((i n (1- i)))
      ((< i 1))
      (cond ((eql ch 10) (terpri))
	    (t (tyo ch)))))


(defun msg-print (item)
   (princ item))


(defmacro dv (sym val) `(defvar ,sym ',val))


(defmacro cnth (l n)
    (let ((g (gensym)))
	 `(let ((,g ,n))
	       (if (< 0 ,g)
		   (nthcdr (1- ,g) ,l)
		   (cons nil ,l)))))


(eval-when (eval load compile)
    (defun dlet-eval (arg value)
	   (cond ((null arg) nil)
		 ((atom arg) (cons arg (list value)))
		 (t (append (dlet-eval (car arg) (cons 'car (list value)))
			    (dlet-eval (cdr arg) (cons 'cdr (list value))))))))

(defmacro dlet (arg-list &body body)
    (let* ((varlist (mapcar #'(lambda (var-val &aux (g (gensym)))
				      (do ((setq-form (dlet-eval (car var-val)
							  g)
					       (cddr setq-form))
					   (let-form nil))
					  ((null setq-form)
					   (cons (list g (second var-val))
						 let-form))
					  (push (list (car setq-form)
						      (second setq-form))
						let-form))) arg-list)))
	  `(let  ,(mapcar #'car varlist)
		 (let ,(mapcan #'cdr varlist)
		      ,@body))))


(defmacro defprop (symbol value property)
    `(setf (get ',symbol ',property) ',value))

(defmacro set-if-unbound (var val)
    `(and (not (boundp ',var))
	  (setq ,var ,val)))

(defmacro is-boundp (sym)
  `(if (boundp ',sym)
       ,sym
       nil))

(defmacro mpcan* (&rest lst)
    `(mapcan ,(car (reverse lst))
	     ,(reverse (cdr (reverse lst)))))

(defmacro possition-in-list (key lis)
    `(do ((cur ,lis (cdr cur))
	  (n 1 (1+ n)))
	 ((or (null cur) (equal ,key (car cur)))
	  (if cur n 0))))

(defmacro fll1 (var-list &rest body)
    (let ((parm (gensym)))
	 `(function (lambda (,parm)
			    (let ((,var-list ,parm))
				 ,@body)))))

(putd 'plist (getd 'symbol-plist))

(putd 'alphalessp (getd 'string-lessp))

;;(defmacro substring (thing start &optional len)
;;    `(let ((str (if (stringp ,thing)
;;		    ,thing
;;		    (princ-to-string ,thing))))
;;	  (if (>= (length str) (abs ,start))
;;	      ,(if (null len)
;;		   `(if (not (minusp ,start))
;;			(subseq str (1- ,start))
;;			(subseq str (+ (strlen ,thing) ,start)))
;;		   `(cond ((and (minusp ,len)
;;				(minusp ,start))
;;			   (substring ,thing ,start))
;;			  ((minusp ,len)
;;			   (subseq str (1- ,start)))
;;			  ((minusp ,start)
;;			   (subseq (substring ,thing ,start)
;;				   0 ,len))
;;			  (t (subseq str (1- ,start) (+ (1- ,start)
;;							,len)))))
;;	      "")))

(putd 'greaterp (getd '>))
(putd 'lessp (getd '<))
(putd 'quotient (getd '/))
(defmacro splitlist (l n)
	     (let ((g (gensym))
		   (g2 (gensym))
		   (g3 (gensym))
		   (g4 (gensym)))
		  `(do ((,g (floor ,n))
			(,g2 nil (cons (car ,g3) ,g2))
			(,g3 ,l (cdr ,g3))
			(,g4 0 (1+ ,g4)))
		       ((>= ,g4 ,g) (cons ,g2 ,g3)))))

(putd 'diff (getd '-))

(defmacro fsize (arg)
   `(length (the string (princ-to-string ,arg))))

;;; (putprop a (delete b (get a c)) c)
(defmacro putdel (a b c)
    `(setf (get ,a ,c) (delete ,b (get ,a ,c))))

;;; (setq b (delete a b))
(defmacro setdel (a b)
    `(setq ,b (delete ,a ,b)))

; Always takes a symbol and deletes the old ele from the symbol list, 
; otherwise returns nil
(defmacro popold (old sym)
    `(cond ((memb ,old (eval ,sym)) 
	    (set ,sym (delete ,old (eval ,sym))))
	   (t nil)))

; dsetq
; this is a destructuring setq.  it uses the common lisp psetq 
; (parallel assignment) operator to define variables to parts of
; the structure given. the special symbol NIL causes the current
; position in the structure to be ignored.
(defmacro dsetq (arg-form val)
    `(let ((value ,val))
	  (setq ,@(eval-dsetq arg-form 'value))))


(eval-when (load eval compile)
    (defun eval-dsetq (a-f v)
	   (cond ((null a-f) nil)
		 ((atom a-f) (cons a-f (list v)))
		 (t (append (eval-dsetq (car a-f) (cons 'car (list v)))
			    (eval-dsetq (cdr a-f) (cons 'cdr (list v))))))))


(defmacro let-assoc (vars assoc-list &rest body)
    `(let ,(mapcar (funl (v) `(,v (cdr (assoc ',v (cdr ,assoc-list)))))
		   vars)
	  ,@body))


;;; Another form of msg installed for Stephen's convenience.
;;;   (E exp) - eval exp and don't print
;;;   (T n)   - tab to col n
;;;   (N n)   - n terpris
;;;   (B n)   - n blanks
;;;   string  - princ the string
;;;   other   - eval and print
;;;  The printing is all done to port $outport$




(defmacro let-assoc-slots (vars assocs assoc-list &rest body)
    `(let ,(mapcar (funl (v a)
			 `(,v (cdr (assoc ',a (cdr ,assoc-list)))))
		   vars assocs)
	  ,@body))

;(defmacro get-binding (var blst)
;    `(eval (cadr (memb ,var ,blst))))

;(defmacro put-binding (var value blst)
;    `(attach ,var (attach (ptr ,value) ,blst)))

;(defun change-binding (var newvalue blst)
;    (rplaca (cdr (memb var blst)) (ptr newvalue))
;    blst)

(defvar *macros-loaded* t)