;;; -*- Mode:Common-Lisp; Package:L; Base:10 -*-
;;;
;;; preasm macros
;;;
;;; jsp 21-April-88



;;; Macros
;;;
;;; Here are various general macros written for use in this package.  More specific macros appear just
;;; before their usage.


;;; string-to-integer
;;;
;;; This macro converts a string into its integer equivalent.  For purposes of generality, the conversion can be
;;; started at an arbitrary position within the string.
;;;
;;; aea 1/21/88 this is simpler in common lisp (see page 381 CL) ...

(defun string-to-integer (string &optional (start 0) (radix 10))
  (parse-integer string :start start :radix radix))


;;; pushnew-end
;;;
;;; This is a combination of pushnew and push-end, and infact is combined code from both.  It has one STRONG
;;; difference, if the value is found in the list, then NIL is returned, rather than the entire list.

(defmacro pushnew-end (value place &rest options)
  "Add VALUE to the end of the list PLACE"
  (declare (arglist value place &key test test-not key))
  (let ((pl (gensym))
	(val (gensym)))
    (si:sublis-eval-once `((,val . ,value) (,pl . ,place))
			 `(if (member ,val ,pl ,@options)
			      '() 						; used to be ,pl
			      (values (setf ,place (nconc ,pl (cons ,val '()))))))))

;;; nremove
;;;
;;; This returns a destructively-modified list that has all instances of <item> removed from <list>.
;;; Use for value rather than side effect.

(defun nremove (item list)
  "Returns a destructively-modified list that has all instances of <item> removed from <list>.
Use for value rather than side effect."
  (loop for partial-list on list
	do (loop as elt = (second partial-list)
		 until (= 1 (length partial-list))
		 until (if (eq elt item)
			   (progn
			     (rplacd partial-list (cddr partial-list))
			     '())
			   t)))
  (if (eq item (first list))
      (rest list)
      list)
  )



;;; zip-remove
;;;
;;; This removes an item from a list, doing the Right Thing.  That is, correctly side-effecting the list.

(defmacro zip-remove (item list)
  "Remove an item from a list.  Fully side-effective."
  (declare (arglist item list))
  (let ((itm (gensym))
	(lst (gensym)))
    (si:sublis-eval-once `((,lst . ,list) (,itm . ,item))
			 `(values (setf ,list (nremove ,itm ,lst))))))


;;; zip-replace
;;;
;;; This replaces one item with another in a list, doing the Right Thing.  That is, correctly side-effecting the list.

(defmacro zip-replace (new-item old-item list)
  "Replace an item with another on a list.  Fully side-effective."
  (declare (arglist new-item old-item list))
  (let ((new (gensym))
	(old (gensym))
	(lst (gensym)))			   
    (si:sublis-eval-once `((,lst . ,list) (,new . ,new-item) (,old . ,old-item))
			 `(values (setf ,list (nsubst ,new ,old ,lst))))))












(defvar *print-il-control-panel-variable-list* '())

;;; define-print-il-option
;;;
;;; This allows the definition of various il printing options, on a nice panel, a la compiler options.

(defmacro define-print-il-option (name description default-value option-values)
  "define a new il-printing option switch"
  `(progn
     (defvar ,name ,default-value ,description)
     (setq *print-il-control-panel-variable-list*
	   (delete-old-entry ',name *print-il-control-panel-variable-list*))
     (push-end '(,name ,description ,@option-values) *print-il-control-panel-variable-list*)
     ',name))

(defun print-il-control-panel ()
  (w:choose-variable-values *print-il-control-panel-variable-list* :label "IL Printing Option Panel"))





(defvar *print-t-control-panel-variable-list* '())

;;; define-print-t-option
;;;
;;; This allows the definition of various il printing options, on a nice panel, a la compiler options.

(defmacro define-print-t-option (name description default-value option-values)
  "define a new t-printing option switch"
  `(progn
     (defvar ,name ,default-value ,description)
     (setq *print-t-control-panel-variable-list*
	   (delete-old-entry ',name *print-t-control-panel-variable-list*))
     (push-end '(,name ,description ,@option-values) *print-t-control-panel-variable-list*)
     ',name))

(defun print-t-control-panel ()
  (w:choose-variable-values *print-t-control-panel-variable-list* :label "IL Printing Option Panel"))




(defvar *main-control-panel-variable-list* '())

;;; define-main-option
;;;
;;; This allows the definition of various compiler options, on a nice panel.

(defmacro define-main-option (name description default-value option-values)
  "define a new compiler option switch"
  `(progn
     (defvar ,name ,default-value ,description)
     (setq *main-control-panel-variable-list*
	   (delete-old-entry ',name *main-control-panel-variable-list*))
     (push-end '(,name ,description ,@option-values) *main-control-panel-variable-list*)
     ',name))

(defun main-control-panel ()
  (w:choose-variable-values *main-control-panel-variable-list* :label "Main Compiler Option Panel"))




;;; This co-ordinates all of the compiler-object printing options.  This panel is invoked via a <term>-M-l, which
;;; allows the user to chose which CO he wishes to change.  This prevents having a multiplicity of hot keys.

(defun print-options ()
  (let ((choice (w:menu-choose '(("il-node" :value (print-il-control-panel))
				 ("main"    :value (main-control-panel))
				 ("t-node"  :value (print-t-control-panel)))
			       :label "Select a Printing Option menu")))
    (when choice (eval choice))
    )
  t
  )

(defun print-compiler-objects-control-panel-key (&optional (ignore))
  (print-options))

(tv:add-terminal-key #\m-l 'print-compiler-objects-control-panel-key
  "pop up the printing option control panel for compiler objects")










(defun set-similarities* (list1 list2 &OPTIONAL (test #'EQL) key test-not)
  (remove-if #'(lisp:lambda (x) (not (sys:member* x list2 test key test-not))) (The List list1) :key key))

(defun set-similarities (list1 list2 &KEY key (test #'EQL) test-not)
  "create a list consisting all of items in list1 not appearing in list2."
  (set-similarities* list1 list2 test key test-not))



(defun list-pos (elt list)
  (loop for l in list
	 as n from 0
	 do (if (eq l elt)
		(return n))
	 finally (return '())))




(defun multi-simple-nsubst (new-list old-list tree)
  "Essentially substitute NEW for OLD in TREE which is a tree of conses.
 Each cons and atom in TREE is tested against OLD. When there is a match,
NEW is substituted for OLD.  TREE is altered by the invocation."
  
  (loop for new in new-list
	as old in old-list
	do (if (eq tree new) (return old))
	finally (cond ((atom tree) tree)
		      (t 
		       (let ((new-left-subtree  (multi-simple-nsubst new-list old-list (car tree)))
			     (new-right-subtree (multi-simple-nsubst new-list old-list (cdr tree))))
			 (unless (eql new-left-subtree (car tree))
			   (setf (car tree) new-left-subtree))
			 (unless (eql new-right-subtree (cdr tree))
			   (setf (cdr tree) new-right-subtree))
			 tree))))
  )




;;; flatten
;;;
;;; This takes an object and returns it in a single-level list.  If the object is not a list (e.g. 'foo), it returns
;;; the object in a list (e.g. '(foo)).  If the object is a multi-level list (e.g. '(1 2 (3 (4)))), then it returns
;;; a list whose elements are the atomic elements of the input object appearing in depth-first order (e.g. '(1 2 3 4)).

(defun flatten (elt)
  (if (listp elt)
      (loop for smaller-elt in elt
	    nconcing (flatten smaller-elt))
      (list elt)))