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

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

parent b861cf4a
......@@ -96,6 +96,38 @@
(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
;; this right can be quite a lot of work, but making a start is cheap.
......@@ -220,9 +252,8 @@
(multiple-value-bind (key values)
(active-keyword spec-pairs)
(when key
(let ((this-keyword-arg (find key (arglist.keyword-args decoded-arglist)
:key 'keyword-arg.keyword)))
(when this-keyword-arg
(when-let (this-keyword-arg (find key (arglist.keyword-args decoded-arglist)
:key 'keyword-arg.keyword))
;; Mangle the arglist structure: only show the keyword we're working on.
(let ((local-arglist (copy-arglist decoded-arglist)))
(setf (arglist.keyword-args local-arglist) (list this-keyword-arg)
......@@ -236,7 +267,7 @@
(values (augment-gendl-define-object (keyword-arg.keyword this-keyword-arg)
local-arglist
values)
determining-args t)))))))))
determining-args t))))))))
;; &allow-other-keys and &rest don't contribute anything here.
(setf (arglist.rest decoded-arglist) nil
(arglist.allow-other-keys-p decoded-arglist) nil)
......@@ -286,12 +317,6 @@
;; We haven't got far enough to say anything yet.
`((,(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
......@@ -305,8 +330,9 @@
(multiple-value-bind (key values)
(active-keyword spec-pairs)
(when key
(let* ((value (car (last values)))
(new-form ;; (To do: hive this off as a separate GF.)
(let ((value (car (last values))))
;; Can we do anything with this keyword?
(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)))
......@@ -322,9 +348,8 @@
(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?
(when new-form
:allow-other-keys-p t)))))))))
;; Apply original defintion of find-subform-with-arglist to gendl:make-self form.
(return-from find-define-object-subform
(funcall finder new-form))))))))
......@@ -361,9 +386,8 @@
If the class wasn't a subclass of gendl:vanilla-mixin* then return nil"
(when (and classname
(symbolp classname)
(let ((class (find-class classname nil)))
(when class
(subtypep class 'gendl:vanilla-mixin*))))
(when-let (class (find-class classname nil))
(subtypep class 'gendl:vanilla-mixin*)))
(let ((prototype (gendl-class-prototype classname)))
(values t
(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."
(let ((class-name (etypecase class
(symbol class)
(class (class-name class)))))
(or (get class-name 'gendl-class-prototype)
(setf (get class-name 'gendl-class-prototype)
(gendl:make-object class)))))
(orf (get class-name 'gendl-class-prototype)
(gendl:make-object class))))
(defun internal-name-p (keyword)
(let ((symbol-name (symbol-name keyword)))
......@@ -419,13 +442,15 @@ each returning a list of proposed messages.")
(defun embedded-the-arglist ()
(let* ((whole-form *form-with-arglist*)
(*this-the* (this-the-from-form whole-form))
(messages (when (and (consp whole-form)
(*this-the* (or (this-the-from-form whole-form)
;; The gend:the form isn't embedded inside a define-object. Bail out.
(return-from embedded-the-arglist
nil))))
(when-let (messages (when (and (consp whole-form)
(eq (car whole-form) 'gendl:define-object))
(remove-duplicates (loop for locator in *message-locators* append
(funcall locator whole-form))
:from-end t))))
(when messages
:from-end t)))
(values (make-arglist :key-p t
:keyword-args (loop for message in messages collect
(make-keyword-arg message message nil))
......@@ -434,14 +459,14 @@ each returning a list of proposed messages.")
:rest 'reference-chain)
nil t))))
;; 9.1. Analyse the current gendl:the form
(defstruct (this-the
(:constructor make-this-the (section slot-form the-form
&aux
(functionp (and (consp the-form)
;; Selects "(the (..."
(consp (second the-form))))
(functionp (when (consp the-form)
(the-form-functionp (cdr the-form))))
(quantifiedp (quantified-objects-p section slot-form the-form)))))
section
slot-form
......@@ -449,6 +474,22 @@ each returning a list of proposed messages.")
functionp
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)
(and (case section
((objects hidden-objects) t))
......@@ -458,24 +499,13 @@ each returning a list of proposed messages.")
(case operator
((gendl:the-child)
;; It's a the-child inside an :object or :hidden-object.
;; Look graciously for a :sequence key.
(loop for key in (cdr slot-form) by #'cddr
thereis (eq key :sequence)))))))
(not (null (find-key :sequence (cdr slot-form)))))))))
;; Try repeating the name of this function, many times, fast, and in a darkened room.
(defun this-the-from-form (form)
;; A bit like messages-in-this-form below, best done as a separate cycle.
;;
;;
;; 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
(when (eq (car form) 'gendl:define-object)
(destructuring-bind (classname &optional mixins
&key input-slots computed-slots objects hidden-objects functions methods
&allow-other-keys)
......@@ -487,10 +517,9 @@ each returning a list of proposed messages.")
(loop for item in section
when (consp item)
do
(let ((form-with-cursor-marker (form-with-cursor-marker item)))
(when form-with-cursor-marker
(when-let (form-with-cursor-marker (form-with-cursor-marker item))
(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)
......@@ -500,13 +529,12 @@ each returning a list of proposed messages.")
do
(cond ((eq thing '%cursor-marker%) (return form))
((consp thing)
(let ((inner-form (form-with-cursor-marker thing)))
(when inner-form
(when-let (inner-form (form-with-cursor-marker thing))
(if (and (consp inner-form)
(case (car inner-form)
((gendl:the gendl:the-child gendl:the-object) t)))
(return inner-form)
(return thing))))))))
(return thing)))))))
;; 9.2. Messages which we can deduce from the current form.
......@@ -554,17 +582,7 @@ gendl:the (etc) form under construction."
(defun messages-from-classes (form)
"Use message-list to find out what the messages might be."
(let* ((starting-classes (destructuring-bind (classname &optional mixins &rest keywords)
(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)))))
(let* ((starting-classes (starting-classes form))
(mixins (remove-duplicates (append (mapcar 'class-name starting-classes)
(loop for class in starting-classes append
(gendl:the-object (gendl-class-prototype class) all-mixins)))
......@@ -574,9 +592,61 @@ gendl:the (etc) form under construction."
'string<)))))
(filter-sequence-messages messages)))
(defmethod safe-find-class ((self symbol)) (find-class self nil))
(defmethod safe-find-class ((self class)) self)
(defmethod safe-find-class ((self t)) nil)
(defun starting-classes (form)
(destructuring-bind (classname &optional mixins &rest keywords)
(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
;; might be redundant with something we already have defined
......@@ -590,46 +660,71 @@ gendl:the (etc) form under construction."
"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."
(unless (find class '(gendl::gdl-basis standard-object t))
(multiple-value-bind (functionp current)
(when-let (this-the (when (boundp '*this-the*) *this-the*))
(values (this-the-functionp this-the)
;; Use this to check we don't return the current slot as a potential message.
;; But messages -- as in (the message-list) -- are keywords and this isn't...
(when-let (current (car (this-the-slot-form this-the)))
(glisp:intern current :keyword))))
(let* ((prototype (gendl-class-prototype class))
(functionp (and (boundp '*this-the*)
(this-the-functionp *this-the*)))
(functions (gendl:the-object prototype (message-list :category :functions
:message-type :local)))
(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 (find keyword *messages-to-suppress*)
(not (or (eq keyword current)
(find keyword *messages-to-suppress*)
(null (gendl:the-object prototype (message-remarks keyword))))))
:normal)))))
(lambda (category keyword)
(declare (ignore category))
(not (eq keyword current)))))))
(sequences (loop for message in all-messages
for source = (cadr (gendl:the-object prototype (slot-source message)))
when (and (consp source)
(find-key :sequence source))
collect message))
(functions (gendl:the-object prototype (message-list :category :functions
:message-type :local))))
;; Preserve order
(loop for message in all-messages
for found = (not (null (find message functions)))
if (eq found functionp)
collect message))))
;; 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
for found = (and functions
(not (null (find message functions))))
when (or (eq found functionp)
(and sequences
(find message sequences)))
collect message)))))
(defun filter-sequence-messages (messages)
(if (and (boundp '*this-the*)
(this-the-quantifiedp *this-the*))
messages
;; Again, we preserve order
(let ((suppress *messages-to-suppress-when-not-sequence-member*))
(loop for message in messages
unless (find message *messages-to-suppress-when-not-sequence-member*)
collect message)))
unless (find message suppress)
collect message))))
;; 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.
;; Return the final (:keyword stuff) pair as two values, provided stuff is a list.
;; Otherwise return nil.
......
......@@ -54,24 +54,19 @@
#+#: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)
;; 4. Load the slime integration. Ideally this should be done
;; (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
;; 3a. This is a workaround for https://bugs.launchpad.net/slime/+bug/1175550
;; "#+lispworks Gray slime-output-stream doesn't handle non base-chars"
#+:lispworks
(setf (slot-value *standard-output* 'swank-backend::buffer)
(coerce (slot-value *standard-output* 'swank-backend::buffer)
'lw:simple-text-string))
(let ((swank-backend-buffer (find-symbol "BUFFER" "SWANK-BACKEND")))
(setf (slot-value *standard-output* swank-backend-buffer)
(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)))
(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