Commit 341cc527 authored by unknown's avatar unknown
Browse files

Crinkles 2013-05-23 ##1,2,5,6

parent b861cf4a
...@@ -96,6 +96,38 @@ ...@@ -96,6 +96,38 @@
(test-def-wrap) (test-def-wrap)
;; I keep needing these.
(defmacro orf (location form &environment env)
(multiple-value-bind (vars values new setter getter)
(get-setf-expansion location env)
(when (cdr new)
(error "Can't work with setf-expansion for ~s - ~d values from setter ~s"
location (length new) new))
(let ((current (car new)))
`(let* (,@(mapcar 'list vars values)
(,current ,getter))
(or ,current
(progn (setf ,current ,form)
,setter))))))
#-:lispworks
(defmacro when-let (binding &body body)
(destructuring-bind (var val) binding
`(let ((,var ,val))
(when ,var
,@body))))
#||
#-:lispworks
(defmacro when-let* (bindings &body body)
(if bindings
`(when-let ,(car bindings)
(when-let* ,(cdr bindings)
,@body))
`(progn ,@body)))
||#
;; We could do with more informative error handling than SLIME provides. Getting ;; We could do with more informative error handling than SLIME provides. Getting
;; this right can be quite a lot of work, but making a start is cheap. ;; this right can be quite a lot of work, but making a start is cheap.
...@@ -220,23 +252,22 @@ ...@@ -220,23 +252,22 @@
(multiple-value-bind (key values) (multiple-value-bind (key values)
(active-keyword spec-pairs) (active-keyword spec-pairs)
(when key (when key
(let ((this-keyword-arg (find key (arglist.keyword-args decoded-arglist) (when-let (this-keyword-arg (find key (arglist.keyword-args decoded-arglist)
:key 'keyword-arg.keyword))) :key 'keyword-arg.keyword))
(when this-keyword-arg ;; Mangle the arglist structure: only show the keyword we're working on.
;; Mangle the arglist structure: only show the keyword we're working on. (let ((local-arglist (copy-arglist decoded-arglist)))
(let ((local-arglist (copy-arglist decoded-arglist))) (setf (arglist.keyword-args local-arglist) (list this-keyword-arg)
(setf (arglist.keyword-args local-arglist) (list this-keyword-arg) (arglist.rest local-arglist) nil
(arglist.rest local-arglist) nil (arglist.allow-other-keys-p local-arglist) t
(arglist.allow-other-keys-p local-arglist) t ;; Disable highlighting.
;; Disable highlighting. *autodoc-highlighting* nil)
*autodoc-highlighting* nil) (return-from compute-enriched-decoded-arglist
(return-from compute-enriched-decoded-arglist ;; If we can, make the init-slots for this keyword appear to be
;; If we can, make the init-slots for this keyword appear to be ;; its default initargs. Behold! That makes them look just right.
;; its default initargs. Behold! That makes them look just right. (values (augment-gendl-define-object (keyword-arg.keyword this-keyword-arg)
(values (augment-gendl-define-object (keyword-arg.keyword this-keyword-arg) local-arglist
local-arglist values)
values) determining-args t))))))))
determining-args t)))))))))
;; &allow-other-keys and &rest don't contribute anything here. ;; &allow-other-keys and &rest don't contribute anything here.
(setf (arglist.rest decoded-arglist) nil (setf (arglist.rest decoded-arglist) nil
(arglist.allow-other-keys-p decoded-arglist) nil) (arglist.allow-other-keys-p decoded-arglist) nil)
...@@ -286,12 +317,6 @@ ...@@ -286,12 +317,6 @@
;; We haven't got far enough to say anything yet. ;; We haven't got far enough to say anything yet.
`((,(cautious-intern "NAME") &key type &allow-other-keys) &rest ,(cautious-intern "MORE-OBJECTS")))) `((,(cautious-intern "NAME") &key type &allow-other-keys) &rest ,(cautious-intern "MORE-OBJECTS"))))
(defun cautious-intern (string)
(if (eq (readtable-case *readtable*) :preserve)
;; Allegro modern mode?
(intern (string-downcase string))
(intern string)))
;; 7. KEYWORD COMPLETION ;; 7. KEYWORD COMPLETION
...@@ -305,26 +330,26 @@ ...@@ -305,26 +330,26 @@
(multiple-value-bind (key values) (multiple-value-bind (key values)
(active-keyword spec-pairs) (active-keyword spec-pairs)
(when key (when key
(let* ((value (car (last values))) (let ((value (car (last values))))
(new-form ;; (To do: hive this off as a separate GF.)
(case key
((:objects
:hidden-objects) (let ((keywords (loop for x in (cdr value) until (arglist-dummy-p x) collect x)))
(multiple-value-bind (proceed name type input-slots)
(destructure-implicit-make-object
(cons (intern (undummy (car value))) keywords))
(declare (ignore name input-slots))
(if proceed
`(gendl:make-self ,type)
;; Nothing useful found. Bail out.
(return-from find-define-object-subform
(values '(gendl:make-self)
(make-arglist :key-p t
:keyword-args (unless (find :type keywords)
(list (make-keyword-arg :type :type nil)))
:allow-other-keys-p t))))))))))
;; Can we do anything with this keyword? ;; Can we do anything with this keyword?
(when new-form (when-let (new-form ;; (To do: hive this off as a separate GF.)
(case key
((:objects
:hidden-objects) (let ((keywords (loop for x in (cdr value) until (arglist-dummy-p x) collect x)))
(multiple-value-bind (proceed name type input-slots)
(destructure-implicit-make-object
(cons (intern (undummy (car value))) keywords))
(declare (ignore name input-slots))
(if proceed
`(gendl:make-self ,type)
;; Nothing useful found. Bail out.
(return-from find-define-object-subform
(values '(gendl:make-self)
(make-arglist :key-p t
:keyword-args (unless (find :type keywords)
(list (make-keyword-arg :type :type nil)))
:allow-other-keys-p t)))))))))
;; Apply original defintion of find-subform-with-arglist to gendl:make-self form. ;; Apply original defintion of find-subform-with-arglist to gendl:make-self form.
(return-from find-define-object-subform (return-from find-define-object-subform
(funcall finder new-form)))))))) (funcall finder new-form))))))))
...@@ -361,9 +386,8 @@ ...@@ -361,9 +386,8 @@
If the class wasn't a subclass of gendl:vanilla-mixin* then return nil" If the class wasn't a subclass of gendl:vanilla-mixin* then return nil"
(when (and classname (when (and classname
(symbolp classname) (symbolp classname)
(let ((class (find-class classname nil))) (when-let (class (find-class classname nil))
(when class (subtypep class 'gendl:vanilla-mixin*)))
(subtypep class 'gendl:vanilla-mixin*))))
(let ((prototype (gendl-class-prototype classname))) (let ((prototype (gendl-class-prototype classname)))
(values t (values t
(append (gendl:the-object prototype (message-list :category :required-input-slots)) (append (gendl:the-object prototype (message-list :category :required-input-slots))
...@@ -377,9 +401,8 @@ doesn't matter. For others it does. So we'll make an object and cache it." ...@@ -377,9 +401,8 @@ doesn't matter. For others it does. So we'll make an object and cache it."
(let ((class-name (etypecase class (let ((class-name (etypecase class
(symbol class) (symbol class)
(class (class-name class))))) (class (class-name class)))))
(or (get class-name 'gendl-class-prototype) (orf (get class-name 'gendl-class-prototype)
(setf (get class-name 'gendl-class-prototype) (gendl:make-object class))))
(gendl:make-object class)))))
(defun internal-name-p (keyword) (defun internal-name-p (keyword)
(let ((symbol-name (symbol-name keyword))) (let ((symbol-name (symbol-name keyword)))
...@@ -419,13 +442,15 @@ each returning a list of proposed messages.") ...@@ -419,13 +442,15 @@ each returning a list of proposed messages.")
(defun embedded-the-arglist () (defun embedded-the-arglist ()
(let* ((whole-form *form-with-arglist*) (let* ((whole-form *form-with-arglist*)
(*this-the* (this-the-from-form whole-form)) (*this-the* (or (this-the-from-form whole-form)
(messages (when (and (consp whole-form) ;; The gend:the form isn't embedded inside a define-object. Bail out.
(eq (car whole-form) 'gendl:define-object)) (return-from embedded-the-arglist
(remove-duplicates (loop for locator in *message-locators* append nil))))
(funcall locator whole-form)) (when-let (messages (when (and (consp whole-form)
:from-end t)))) (eq (car whole-form) 'gendl:define-object))
(when messages (remove-duplicates (loop for locator in *message-locators* append
(funcall locator whole-form))
:from-end t)))
(values (make-arglist :key-p t (values (make-arglist :key-p t
:keyword-args (loop for message in messages collect :keyword-args (loop for message in messages collect
(make-keyword-arg message message nil)) (make-keyword-arg message message nil))
...@@ -434,14 +459,14 @@ each returning a list of proposed messages.") ...@@ -434,14 +459,14 @@ each returning a list of proposed messages.")
:rest 'reference-chain) :rest 'reference-chain)
nil t)))) nil t))))
;; 9.1. Analyse the current gendl:the form ;; 9.1. Analyse the current gendl:the form
(defstruct (this-the (defstruct (this-the
(:constructor make-this-the (section slot-form the-form (:constructor make-this-the (section slot-form the-form
&aux &aux
(functionp (and (consp the-form) (functionp (when (consp the-form)
;; Selects "(the (..." (the-form-functionp (cdr the-form))))
(consp (second the-form))))
(quantifiedp (quantified-objects-p section slot-form the-form))))) (quantifiedp (quantified-objects-p section slot-form the-form)))))
section section
slot-form slot-form
...@@ -449,6 +474,22 @@ each returning a list of proposed messages.") ...@@ -449,6 +474,22 @@ each returning a list of proposed messages.")
functionp functionp
quantifiedp) quantifiedp)
;; Select "(the ... (..."
(defun the-form-functionp (form)
(when form
(or (and (consp (car form))
(or (eq (cadr form) '%cursor-marker%)
(null (cdr form))))
(the-form-functionp (cdr form)))))
;; If we are inside an :object or :hidden-object specification, and
;; one of the input keys is ":sequence", then "(the-child ..." should
;; include display of the sequence messages as well as (in this case)
;; the user-visible messages for 'box. Otherwise, the "sequence
;; messages" should be suppressed.
;;
;; http://paste.lisp.org/display/137258
(defun quantified-objects-p (section slot-form the-form) (defun quantified-objects-p (section slot-form the-form)
(and (case section (and (case section
((objects hidden-objects) t)) ((objects hidden-objects) t))
...@@ -458,24 +499,13 @@ each returning a list of proposed messages.") ...@@ -458,24 +499,13 @@ each returning a list of proposed messages.")
(case operator (case operator
((gendl:the-child) ((gendl:the-child)
;; It's a the-child inside an :object or :hidden-object. ;; It's a the-child inside an :object or :hidden-object.
;; Look graciously for a :sequence key. (not (null (find-key :sequence (cdr slot-form)))))))))
(loop for key in (cdr slot-form) by #'cddr
thereis (eq key :sequence)))))))
;; Try repeating the name of this function, many times, fast, and in a darkened room. ;; Try repeating the name of this function, many times, fast, and in a darkened room.
(defun this-the-from-form (form) (defun this-the-from-form (form)
;; A bit like messages-in-this-form below, best done as a separate cycle. ;; A bit like messages-in-this-form below, best done as a separate cycle.
;; (when (eq (car form) 'gendl:define-object)
;;
;; FLAG DJC -- this ignore-errors MUST BE REMOVED (or at least catch
;; the error)! Put as a band-aid by DJC in order to get
;; some work done without quitting & restarting the
;; system.
;;
(ignore-errors
(destructuring-bind (classname &optional mixins (destructuring-bind (classname &optional mixins
&key input-slots computed-slots objects hidden-objects functions methods &key input-slots computed-slots objects hidden-objects functions methods
&allow-other-keys) &allow-other-keys)
...@@ -487,10 +517,9 @@ each returning a list of proposed messages.") ...@@ -487,10 +517,9 @@ each returning a list of proposed messages.")
(loop for item in section (loop for item in section
when (consp item) when (consp item)
do do
(let ((form-with-cursor-marker (form-with-cursor-marker item))) (when-let (form-with-cursor-marker (form-with-cursor-marker item))
(when form-with-cursor-marker (return-from this-the-from-form
(return-from this-the-from-form (make-this-the section-name item form-with-cursor-marker))))))))
(make-this-the section-name item form-with-cursor-marker)))))))))
(defun form-with-cursor-marker (form) (defun form-with-cursor-marker (form)
...@@ -500,13 +529,12 @@ each returning a list of proposed messages.") ...@@ -500,13 +529,12 @@ each returning a list of proposed messages.")
do do
(cond ((eq thing '%cursor-marker%) (return form)) (cond ((eq thing '%cursor-marker%) (return form))
((consp thing) ((consp thing)
(let ((inner-form (form-with-cursor-marker thing))) (when-let (inner-form (form-with-cursor-marker thing))
(when inner-form (if (and (consp inner-form)
(if (and (consp inner-form) (case (car inner-form)
(case (car inner-form) ((gendl:the gendl:the-child gendl:the-object) t)))
((gendl:the gendl:the-child gendl:the-object) t))) (return inner-form)
(return inner-form) (return thing)))))))
(return thing))))))))
;; 9.2. Messages which we can deduce from the current form. ;; 9.2. Messages which we can deduce from the current form.
...@@ -554,17 +582,7 @@ gendl:the (etc) form under construction." ...@@ -554,17 +582,7 @@ gendl:the (etc) form under construction."
(defun messages-from-classes (form) (defun messages-from-classes (form)
"Use message-list to find out what the messages might be." "Use message-list to find out what the messages might be."
(let* ((starting-classes (destructuring-bind (classname &optional mixins &rest keywords) (let* ((starting-classes (starting-classes form))
(cdr form)
(declare (ignore keywords))
(let ((this-class (safe-find-class classname)))
(if this-class
;; It's a redefinition
(list this-class)
;; New definition. Hit the superclasses.
(loop for classname in mixins
for class = (safe-find-class classname)
when class collect class)))))
(mixins (remove-duplicates (append (mapcar 'class-name starting-classes) (mixins (remove-duplicates (append (mapcar 'class-name starting-classes)
(loop for class in starting-classes append (loop for class in starting-classes append
(gendl:the-object (gendl-class-prototype class) all-mixins))) (gendl:the-object (gendl-class-prototype class) all-mixins)))
...@@ -574,9 +592,61 @@ gendl:the (etc) form under construction." ...@@ -574,9 +592,61 @@ gendl:the (etc) form under construction."
'string<))))) 'string<)))))
(filter-sequence-messages messages))) (filter-sequence-messages messages)))
(defmethod safe-find-class ((self symbol)) (find-class self nil)) (defun starting-classes (form)
(defmethod safe-find-class ((self class)) self) (destructuring-bind (classname &optional mixins &rest keywords)
(defmethod safe-find-class ((self t)) nil) (cdr form)
(declare (ignore keywords))
(let ((this-class (or (the-child-class)
(safe-find-class classname))))
(if this-class
;; It's a either a (the-child ...) class , or a redefinition
;; (which includes: clicking on an existing defintion).
(the-reference-chain this-class)
;; New definition. Hit the superclasses.
(loop for classname in mixins
for class = (safe-find-class classname)
when class collect class)))))
;; If we're in a the-child inside an :objects or :hidden-objects clause and can find
;; a class for the :type, return that.
(defun the-child-class ()
(when (boundp '*this-the*)
(let ((this-the *this-the*))
(when (and (case (this-the-section this-the)
((objects hidden-objects) t))
(eq (car (this-the-the-form this-the)) 'gendl:the-child))
(object-slot-form-class (cdr (this-the-slot-form this-the)))))))
(defun object-slot-form-class (slot-form)
(multiple-value-bind (typep quoted-type)
(find-key :type slot-form)
(declare (ignore typep))
(when (and (consp quoted-type)
(eq (car quoted-type) 'quote)
(symbolp (cadr quoted-type)))
(find-class (cadr quoted-type) nil))))
(defun the-reference-chain (class)
(unless (arglist-dummy-p class)
(when (boundp '*this-the*)
(let* ((this-the *this-the*)
(the-form (this-the-the-form this-the))
(reference-chain (case (car the-form)
((gendl:the gendl:the-child) (cdr the-form))
((gendl:the-object) (cddr the-form)))))
(loop for reference in reference-chain do
(setf class (or (reference-class reference class)
(return))))))
(list class)))
(defun reference-class (reference class)
(if (or (arglist-dummy-p reference)
(consp reference) ; function call
(eq reference '%cursor-marker%))
class
(let* ((prototype (gendl-class-prototype class))
(slot-source (gendl:the-object prototype (slot-source (glisp:intern reference :keyword)))))
(object-slot-form-class (cadr slot-source)))))
;; [gendl] make your own defparameter for now, but flag it that it ;; [gendl] make your own defparameter for now, but flag it that it
;; might be redundant with something we already have defined ;; might be redundant with something we already have defined
...@@ -590,46 +660,71 @@ gendl:the (etc) form under construction." ...@@ -590,46 +660,71 @@ gendl:the (etc) form under construction."
"Return a list of messages. Take anything from a user-defined class (not "Return a list of messages. Take anything from a user-defined class (not
in one of the *internal-packages*), otherwise filter for non-nil message-remarks." in one of the *internal-packages*), otherwise filter for non-nil message-remarks."
(unless (find class '(gendl::gdl-basis standard-object t)) (unless (find class '(gendl::gdl-basis standard-object t))
(let* ((prototype (gendl-class-prototype class)) (multiple-value-bind (functionp current)
(functionp (and (boundp '*this-the*) (when-let (this-the (when (boundp '*this-the*) *this-the*))
(this-the-functionp *this-the*))) (values (this-the-functionp this-the)
(functions (gendl:the-object prototype (message-list :category :functions ;; Use this to check we don't return the current slot as a potential message.
:message-type :local))) ;; But messages -- as in (the message-list) -- are keywords and this isn't...
(all-messages (gendl:the-object prototype (when-let (current (car (this-the-slot-form this-the)))
(message-list :message-type :local (glisp:intern current :keyword))))
:filter (if (find (symbol-package class) (let* ((prototype (gendl-class-prototype class))
*internal-packages*) (all-messages (gendl:the-object prototype
(message-list :message-type :local
:filter (if (find (symbol-package class)
*internal-packages*)
(lambda (category keyword)
(declare (ignore category))
(not (or (eq keyword current)
(find keyword *messages-to-suppress*)
(null (gendl:the-object prototype (message-remarks keyword))))))
(lambda (category keyword) (lambda (category keyword)
(declare (ignore category)) (declare (ignore category))
(not (or (find keyword *messages-to-suppress*) (not (eq keyword current)))))))
(null (gendl:the-object prototype (message-remarks keyword)))))) (sequences (loop for message in all-messages
:normal))))) for source = (cadr (gendl:the-object prototype (slot-source message)))
;; Preserve order when (and (consp source)
(loop for message in all-messages (find-key :sequence source))
for found = (not (null (find message functions))) collect message))
if (eq found functionp) (functions (gendl:the-object prototype (message-list :category :functions
collect message)))) :message-type :local))))
;; Preserve order
;; If we are inside an :object or :hidden-object specification, and (loop for message in all-messages
;; one of the input keys is ":sequence", then "(the-child ..." should for found = (and functions
;; include display of the sequence messages as well as (in this case) (not (null (find message functions))))
;; the user-visible messages for 'box. Otherwise, the "sequence when (or (eq found functionp)
;; messages" should be suppressed. (and sequences
;; (find message sequences)))
;; http://paste.lisp.org/display/137258 collect message)))))
(defun filter-sequence-messages (messages) (defun filter-sequence-messages (messages)
(if (and (boundp '*this-the*) (if (and (boundp '*this-the*)
(this-the-quantifiedp *this-the*)) (this-the-quantifiedp *this-the*))
messages messages
;; Again, we preserve order ;; Again, we preserve order
(loop for message in messages (let ((suppress *messages-to-suppress-when-not-sequence-member*))
unless (find message *messages-to-suppress-when-not-sequence-member*) (loop for message in messages
collect message))) unless (find message suppress)
collect message))))
;; 10. UTILITIES ;; 10. UTILITIES
(defun cautious-intern (string)
(if (eq (readtable-case *readtable*) :preserve)
;; Allegro modern mode?
(intern (string-downcase string))
(intern string)))
(defmethod safe-find-class ((self symbol)) (find-class self nil))
(defmethod safe-find-class ((self class)) self)
(defmethod safe-find-class ((self t)) nil)
;; Look graciously for key: don't assume list is correctly formed for destructuring-bind.
(defun find-key (key plist)
(loop for (k v) on plist by #'cddr
when (eq k key)
do (return (values k v))))
;; List is of form (:keyword stuff :keyword stuff ...); the final stuff may be missing. ;; List is of form (:keyword stuff :keyword stuff ...); the final stuff may be missing.
;; Return the final (:keyword stuff) pair as two values, provided stuff is a list. ;; Return the final (:keyword stuff) pair as two values, provided stuff is a list.
;; Otherwise return nil. ;; Otherwise return nil.
......
...@@ -54,24 +54,19 @@ ...@@ -54,24 +54,19 @@
#+#:nil (asdf:initialize-source-registry `(:source-registry (:tree ,gendl :inherit-configuration))) #+#:nil (asdf:initialize-source-registry `(:source-registry (:tree ,gendl :inherit-configuration)))
;; 3. Load gendl plus dependencies. ;; 3. Load gendl plus dependencies (including glime).
(funcall (find-symbol (string 'quickload) :ql) :gendl) (funcall (find-symbol (string 'quickload) :ql) :gendl)
;; 4. Load the slime integration. Ideally this should be done ;; 3a. This is a workaround for https://bugs.launchpad.net/slime/+bug/1175550
;; (conditionally) by the quickload above.
#+:swank
(load (compile-file (merge-pathnames "emacs/glime.lisp" gendl)))
;; 4a. This is a workaround for https://bugs.launchpad.net/slime/+bug/1175550
;; "#+lispworks Gray slime-output-stream doesn't handle non base-chars" ;; "#+lispworks Gray slime-output-stream doesn't handle non base-chars"
#+:lispworks #+:lispworks
(setf (slot-value *standard-output* 'swank-backend::buffer) (let ((swank-backend-buffer (find-symbol "BUFFER" "SWANK-BACKEND")))
(coerce (slot-value *standard-output* 'swank-backend::buffer) (setf (slot-value *standard-output* swank-backend-buffer)
'lw:simple-text-string)) (coerce (slot-value *standard-output* swank-backend-buffer)
'lw:simple-text-string)))
;; 5. Start gendl. ;; 4. Start gendl.
(let ((starter (find-symbol (string 'start-gendl!) :gendl))) (let ((starter (find-symbol (string 'start-gendl!) :gendl)))
(funcall starter))) (funcall starter)))
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment