src/utilities.lisp

(in-package :lisp-on-lines)

(defun make-enclosing-package (name)
  (make-package name :use '()))

(defgeneric enclose-symbol (symbol package)
  (:method ((symbol symbol)
            (package package))
   (if (symbol-package symbol)
     (intern (format nil "~A::~A"
                     (package-name (symbol-package symbol))
                     (symbol-name symbol))
             package)
     (or (get symbol package)
         (setf (get symbol package) (gensym))))))

(defmacro with-active-descriptions (descriptions &body body)
       `(with-active-layers ,(mapcar #'defining-description descriptions)

	 ,@body))
#|
Descriptoons are represented as ContextL classes and layers. To avoid nameclashes with other classes or layers, the name of a description is actually mappend to an internal unambiguous name which is used instead of the regular name.
|#


(defvar *description-definers*
  (make-enclosing-package "DESCRIPTION-DEFINERS"))

(defun defining-description (name)
  "Takes the name of a description and returns its internal name."
  (case name
    ((nil) (error "NIL is not a valid description name."))
    (otherwise (enclose-symbol name *description-definers*))))

(defmethod initargs.slots (class)
  "Returns ALIST of (initargs) . slot."
  (mapcar #'(lambda (slot)
	      (cons (closer-mop:slot-definition-initargs slot)
		    slot))
		    (closer-mop:class-slots class)))

(defun find-slot-using-initarg (class initarg)
  (cdr (assoc-if #'(lambda (x) (member initarg x))
				   (initargs.slots class))))


;;;!-- TODO: this has been so mangled that, while working, it's ooogly!
;;;!-- do we still use this?

(defun initargs-plist->special-slot-bindings (class initargs-plist)
  "returns a list of (slot-name value) Given a plist of initargs such as one would pass to :DEFAULT-INITARGS."
  (let ((initargs.slot-names-alist (initargs.slot-names class)))
    (loop for (initarg value) on initargs-plist
	  nconc (let ((slot-name
		    ))
		  (when slot-name ;ignore invalid initargs. (good idea/bad idea?)
		    (list slot-name value))))))

(defun dprint (format-string &rest args)
  (apply #'format t (concatenate 'string format-string "~%") args))
Commit	Line	Data
	1	(in-package :lisp-on-lines)
	2
	3	(defun make-enclosing-package (name)
	4	(make-package name :use '()))
	5
	6	(defgeneric enclose-symbol (symbol package)
	7	(:method ((symbol symbol)
	8	(package package))
	9	(if (symbol-package symbol)
	10	(intern (format nil "~A::~A"
	11	(package-name (symbol-package symbol))
	12	(symbol-name symbol))
	13	package)
	14	(or (get symbol package)
	15	(setf (get symbol package) (gensym))))))
	16
	17	(defmacro with-active-descriptions (descriptions &body body)
	18	`(with-active-layers ,(mapcar #'defining-description descriptions)
	19
	20	,@body))
	21	#\|
	22	Descriptoons are represented as ContextL classes and layers. To avoid nameclashes with other classes or layers, the name of a description is actually mappend to an internal unambiguous name which is used instead of the regular name.
	23	\|#
	24
	25
	26	(defvar description-definers
	27	(make-enclosing-package "DESCRIPTION-DEFINERS"))
	28
	29	(defun defining-description (name)
	30	"Takes the name of a description and returns its internal name."
	31	(case name
	32	((nil) (error "NIL is not a valid description name."))
	33	(otherwise (enclose-symbol name description-definers))))
	34
	35	(defmethod initargs.slots (class)
	36	"Returns ALIST of (initargs) . slot."
	37	(mapcar #'(lambda (slot)
	38	(cons (closer-mop:slot-definition-initargs slot)
	39	slot))
	40	(closer-mop:class-slots class)))
	41
	42	(defun find-slot-using-initarg (class initarg)
	43	(cdr (assoc-if #'(lambda (x) (member initarg x))
	44	(initargs.slots class))))
	45
	46
	47
	48	;;;!-- TODO: this has been so mangled that, while working, it's ooogly!
	49	;;;!-- do we still use this?
	50
	51	(defun initargs-plist->special-slot-bindings (class initargs-plist)
	52	"returns a list of (slot-name value) Given a plist of initargs such as one would pass to :DEFAULT-INITARGS."
	53	(let ((initargs.slot-names-alist (initargs.slot-names class)))
	54	(loop for (initarg value) on initargs-plist
	55	nconc (let ((slot-name
	56	))
	57	(when slot-name ;ignore invalid initargs. (good idea/bad idea?)
	58	(list slot-name value))))))
	59
	60	(defun dprint (format-string &rest args)
	61	(apply #'format t (concatenate 'string format-string "~%") args))
	62
	63
	64
	65