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))))))

#|
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 layer and returns its internal name."
  (case name
    ((t) 't)
    ((nil) (error "NIL is not a valid description name."))
    (otherwise (enclose-symbol name *description-definers*))))


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

(defun find-slot-name-from-initarg (class initarg)
  (cdr (assoc-if #'(lambda (x) (member initarg x))
				   (initargs.slot-names class))))


;;;!-- TODO: this has been so mangled that, while working, it's ooogly!
(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))))))
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	#\|
	18	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.
	19	\|#
	20
	21
	22	(defvar description-definers
	23	(make-enclosing-package "DESCRIPTION-DEFINERS"))
	24
	25	(defun defining-description (name)
	26	"Takes the name of a layer and returns its internal name."
	27	(case name
	28	((t) 't)
	29	((nil) (error "NIL is not a valid description name."))
	30	(otherwise (enclose-symbol name description-definers))))
	31
	32
	33	(defmethod initargs.slot-names (class)
	34	"Returns ALIST of (initargs) . slot-name."
	35	(nreverse (mapcar #'(lambda (slot)
	36	(cons (closer-mop:slot-definition-initargs slot)
	37	(closer-mop:slot-definition-name slot)))
	38	(closer-mop:class-slots class))))
	39
	40	(defun find-slot-name-from-initarg (class initarg)
	41	(cdr (assoc-if #'(lambda (x) (member initarg x))
	42	(initargs.slot-names class))))
	43
	44
	45	;;;!-- TODO: this has been so mangled that, while working, it's ooogly!
	46	(defun initargs-plist->special-slot-bindings (class initargs-plist)
	47	"returns a list of (slot-name value) Given a plist of initargs such as one would pass to :DEFAULT-INITARGS."
	48	(let ((initargs.slot-names-alist (initargs.slot-names class)))
	49	(loop for (initarg value) on initargs-plist
	50	nconc (let ((slot-name
	51	))
	52	(when slot-name ;ignore invalid initargs. (good idea/bad idea?)
	53	(list slot-name value))))))
	54
	55
	56