Commit 88a9d09d authored by Dave Cooper's avatar Dave Cooper

Merge branch 'devo'

parents 1f67928d 9a98df49
(in-package :gdl-user)
(define-object robot-drawing (base-drawing)
:hidden-objects ((robot-assembly :type 'robot:assembly))
:objects
((tri-view :type 'base-view
:border-box? t
:object-roots (list (the robot-assembly robot))
:length (half (the length))
:center (translate (the center) :rear (half (the-child length)))
:projection-vector (getf *standard-views* :trimetric))
(top-view :type 'base-view
:border-box? t
:object-roots (list (the robot-assembly robot))
:annotation-objects (list (the top-width-dim)
(the top-length-dim))
:view-scale (* 0.80 (getf (the-child view-contents-data) :view-scale))
:length (half (the length))
:width (half (the width))
:center (translate (the center) :front (half (the-child length))
:left (half (the-child width)))
:projection-vector (getf *standard-views* :top))
(top-width-dim :type 'horizontal-dimension
:character-size 10
:dim-scale (/ (the top-view view-scale))
:witness-line-length 20
:witness-line-gap 70
:witness-line-ext 5
:start-point (the top-view (view-point (the robot-assembly robot body (arms 0) (vertex :rear :left :top))))
:end-point (the top-view (view-point (the robot-assembly robot body (arms 1) (vertex :rear :right :top)))))
(top-length-dim :type 'vertical-dimension
:dim-scale (/ (the top-view view-scale))
:character-size 10
:witness-line-length 15
:witness-line-gap 25
:witness-line-ext 3
:flip-leaders? t
:start-point (the top-view (view-point (the robot-assembly robot body base foot (vertex :rear :left :top))))
:end-point (the top-view (view-point (the robot-assembly robot body base foot (vertex :front :left :top)))))
(front-view :type 'base-view
:border-box? t
:object-roots (list (the robot-assembly robot))
:length (half (the length))
:width (half (the width))
:center (translate (the center) :front (half (the-child length))
:right (half (the-child width)))
:projection-vector (getf *standard-views* :front))
))
1. On define-object, the arglist in the mini-buffer does not need to
contain the "&rest spec-plist"
2. On define-object, the &key args should be in reverse order
(starting with input-slots computed-slots ...)
3. There's no real need to display "&allow-other-keys"
4. The completion help for the keywords accepted inside an :objects or
:hidden-objects specification looks really nice and I think just
this one feature will help the users a lot!
5. Is there a convenient way temporarily to expand the mini-buffer to
more than one line, to be able to see more info in case it doesn't
fit in one line of mini-buffer?
;;
;; Allegro crinkles
;;
6.
Allegro modern-mode doesn't like:
(in-package "SWANK")
changed to
(in-package :swank) ;; should it be #:swank ?
7. First time compiling gives:
Warning: While compiling these undefined functions were referenced:
wrap-test-original from character position 2825 in
/home/dcooper8/genworks/gendl/emacs/swank/gendl.lisp
do we need an "eval-when" incantation somewhere?
8. In :objects specification, after NAME but before :type is ascertained, we see
(define-object name mixin-list &key (objects ((NAME &key type &allow-other-keys) &rest MORE-OBJECTS)) &allow-other-keys)
a. The "NAME" and "MORE-OBJECTS" in uppercase appears a bit shocking in modern-mode. Do they need to be in uppercase?
b. Do we need the "&allow-other-keys" in this situation?
;; $Id: //info.ravenbrook.com/project/gendl/master/genworks/emacs/gendl.lisp#4 $
(in-package :swank)
;; GENDL.LISP
;; Nick Levine, Ravenbrook Limited, 2013-05-02
;;
;; 1. INTRODUCTION
;;
;; The purpose of this document is to implement GENDL customisations
;; for SLIME.
;;
;; The following features have been implemented so far:
;;
;; * modeline and completion help for the keywords accepted by
;; gendl:define-object,
;;
;; * modeline and completion help for the keywords accepted inside an
;; :objects or :hidden-objects argument to gendl:define-object,
;; gendl:make-object, or gendl:make-self.
;;
;; The intended readership is project developers.
;;
;; This document is not confidential. See end for copyright
;; information.
(defparameter *gendl-slime-release* "0.1.0")
;; 2. TESTS
;;
;; It's handy to be able to test this outside of the SLIME environmemnt.
;;
;; '("define-object" "empty" nil ":objects" ("" swank::%cursor-marker%))
;; ->
;; "(define-object name mixin-list &key ===> objects <=== &allow-other-keys)"
(defun gendl-autodoc-test (raw-form)
(let ((*buffer-package* (find-package "GDL-USER"))
(*buffer-readtable* *readtable*))
(car (autodoc raw-form))))
;; 3. MACROS
;; We need a (very, very) basic and portable advice facility. The
;; potentially dangerous assumption it makes is that the original
;; function won't be redefined behind our backs. I can't think of an
;; easy way to prevent users from doing that. On the other hand,
;; there's no reason why they should.
;; The #+lispworks conditionalisations immediately below are present
;; purely as development aids.
#+lispworks
(dspec:define-dspec-alias def-wrap (name)
`(defun ,name))
(defmacro def-wrap (name lambda-list &body body)
"Wrap BODY around the function defined by NAME. Locally defined #'PUNT
will access the original definition."
(let* ((args-var (gensym "ARGS-"))
(cache-form `(unless (get ',name 'gendl-unwrapped)
(setf (get ',name 'gendl-unwrapped) (symbol-function ',name))))
(wrapped-body `(,@(loop for next = (first body)
while (or (stringp next)
(and (consp next)
(eq (car next) 'declare)))
collect (pop body))
(flet ((punt (&rest ,args-var)
(apply (get ',name 'gendl-unwrapped) ,args-var)))
,@body))))
#+lispworks
`(dspec:def (def-wrap ,name)
,cache-form
(let ((lw:*redefinition-action* :quiet))
(defun ,name ,lambda-list ,@wrapped-body))
',name)
#-lispworks
`(progn
,cache-form
(setf (symbol-function ',name)
(lambda ,lambda-list ,@wrapped-body)))))
(defun wrap-test-original (x)
(cons :original x))
(defun test-def-wrap ()
(def-wrap wrap-test-original (x)
(cons :wrapped (cdr (punt (1+ x)))))
(assert (equal (wrap-test-original 3) '(:wrapped . 4)))
(def-wrap wrap-test-original (x)
(punt x))
(assert (equal (wrap-test-original 3) '(:original . 3))))
(test-def-wrap)
;; 4. ADVISE SWANK FUNCTIONS
;;
;; The main defintions of the four functions wrapped below are all in
;; the contrib file swank-arglists.lisp.
;;
;; We use *autodoc-highlighting* to disable runaway hightlighting when
;; we're showing init-slots in the modeline. The method on
;; compute-enriched-decoded-arglist below might set *autodoc-highlighting*
;; to nil.
(defvar *autodoc-highlighting* t)
;; Used for modeline display of available arguments.
(def-wrap autodoc (raw-form &key print-right-margin)
(let ((*autodoc-highlighting* *autodoc-highlighting*)
;; The default is to view symbols as if we were in the CL-USER
;; package. I can't see how this helps anybody, so I'm
;; disabling it.
(*arglist-show-packages* nil))
(punt raw-form :print-right-margin print-right-margin)))
(def-wrap form-path-to-arglist-path (form-path form arglist)
(when *autodoc-highlighting*
(punt form-path form arglist)))
;; There are two different paths which call find-subform-with-arglist. We
;; want to know which one we're on and we do this by binding
;; *grovelling-for-arglist*.
(defvar *grovelling-for-arglist* nil)
;; Used for (keyword) completion.
(def-wrap find-immediately-containing-arglist (form)
(let ((*grovelling-for-arglist* t))
(punt form)))
;; Invoked by both autodoc and find-immediately-containing-arglist.
(def-wrap find-subform-with-arglist (form)
(if (and *grovelling-for-arglist*
(eq (car form) 'gendl:define-object))
(find-define-object-subform form #'punt)
(punt form)))
;; 5. KEYWORDS ACCEPTED BY DEFINE-OBJECT, MAKE-OBJECT, MAKE-SELF
;;; We make gendl:define-object appear to have the same arglist as
;;; gendl::%define-object% (modulo three keywords which Dave Cooper
;;; says aren't in use.)
(defparameter *define-object-unsupported*
'(:methods :no-vanilla-mixin? :query-slots))
;; See (defgeneric extra-keywords) in swank-arglists.lisp
(defmethod extra-keywords ((operator (eql 'gendl:define-object)) &rest arguments)
(values (reverse (let ((unsupported *define-object-unsupported*))
(loop for keyword-arg in (arglist.keyword-args (compute-enriched-decoded-arglist 'gendl::%define-object% arguments))
unless (find (keyword-arg.keyword keyword-arg) unsupported)
collect keyword-arg)))
t nil))
(defmethod extra-keywords ((operator (eql 'gendl:make-object)) &rest args)
(or (keyword-args-from-class-input-slots (car args))
(call-next-method)))
(defmethod extra-keywords ((operator (eql 'gendl:make-self)) &rest args)
(or (keyword-args-from-class-input-slots (car args))
(call-next-method)))
(defun keyword-args-from-class-input-slots (classname-form)
(when (and (consp classname-form)
(= (length classname-form) 2)
(eq (car classname-form) 'quote))
(let ((classname (cadr classname-form)))
(multiple-value-bind (proceed input-slots)
(class-input-slots classname)
(when proceed
(loop for slot in input-slots collect
(make-keyword-arg slot slot nil)))))))
;; 6. HELP ON SPECIFIC DEFINE-OBJECT KEYWORDS
;;
;; We use the swank interface for "enriching" an arglist. The method
;; below determines whether we're working on a specific keyword
;; A call might look like this:
;; (compute-enriched-decoded-arglist define-object (empty nil :objects (#s(swank::arglist-dummy :string-representation ""))))
;; Note that SLIME has already chopped everything to the right of the
;; cursor maker; editing
;; (define-object empty () :objects ( ) :documentation ())
;; with the cursor here: -->^<--
;; is the same as editing (define-object empty () :objects ()).
;;
;; See (defgeneric compute-enriched-decoded-arglist) in swank-arglists.lisp
(defmethod compute-enriched-decoded-arglist ((operator (eql 'gendl:define-object)) arguments)
(multiple-value-bind (decoded-arglist determining-args any-enrichment)
(call-next-method)
(destructuring-bind (&optional name mixins &rest spec-pairs)
arguments
(declare (ignore name mixins))
;; Has the user got as far as the keyword list yet?
(when spec-pairs
;; Which keyword are they working on?
(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
;; 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)
(arglist.rest local-arglist) nil
(arglist.allow-other-keys-p local-arglist) t
;; Disable highlighting.
*autodoc-highlighting* nil)
(return-from compute-enriched-decoded-arglist
;; If we can, make the init-slots for this keyword appear to be
;; its default initargs. Behold! That makes them look just right.
(values (augment-gendl-define-object (keyword-arg.keyword this-keyword-arg)
local-arglist
values)
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)
(values decoded-arglist determining-args any-enrichment)))
(defgeneric augment-gendl-define-object (keyword arglist values)
(:documentation
"We're editing the value for gendl:define-object keyword KEYWORD. Return
an arglist based on ARGLIST which conveys more information about the
VALUES being edited."
)
(:method (keyword arglist values)
(declare (ignore keyword values))
arglist))
;; 6.1. Keyword support for :objects & :hidden-objects
(defmethod augment-gendl-define-object ((keyword (eql :objects)) arglist values)
(augment-gendl-define-object-for-objects keyword arglist values))
(defmethod augment-gendl-define-object ((keyword (eql :hidden-objects)) arglist values)
(augment-gendl-define-object-for-objects keyword arglist values))
;; Perform basic checks and then treat this as an implicit make-object.
(defun augment-gendl-define-object-for-objects (keyword arglist values)
(let ((keyword-arg (or (find keyword (arglist.keyword-args arglist) :key 'keyword-arg.keyword)
;; Shouldn't get here; playing it safe.
(return-from augment-gendl-define-object-for-objects arglist)))
(value (let ((value (car (last values))))
(if (consp value)
value
(return-from augment-gendl-define-object-for-objects arglist)))))
(setf (keyword-arg.default-arg keyword-arg) (implicit-make-object value)))
arglist)
;; Value is the object-form on which the user is working. It'll be a
;; list consisting of lisp objects interspersed with SWANK arglist-dummies.
(defun implicit-make-object (value)
(or (multiple-value-bind (proceed name type input-slots)
(destructure-implicit-make-object value)
(when proceed
(let ((safe-name (let ((*read-eval* nil))
(read-from-string (undummy name)))))
;; Note use of intern, to ensure hardwired symbols arrive in *package*.
`((,safe-name :type ,type &key ,@input-slots) &rest ,(cautious-intern "MORE-OBJECTS")))))
;; 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
(defun find-define-object-subform (form finder)
(destructuring-bind (&optional name mixins &rest spec-pairs)
(cdr form)
(declare (ignore name mixins))
;; Has the user got onto the keyword list yet?
(when spec-pairs
;; Which keyword are they working on?
(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.)
(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?
(when new-form
;; Apply original defintion of find-subform-with-arglist to gendl:make-self form.
(return-from find-define-object-subform
(funcall finder new-form))))))))
;; No? Apply original defintion of find-subform-with-arglist to original
(funcall finder form))
;; 8. DESTRUCTURING IMPLICIT MAKE-OBJECT FORMS
(defun destructure-implicit-make-object (form)
"If FORM destructures as (SLOTNAME (quote CLASSNAME) ...) and CLASSNAME
names a subclass of gendl:vanilla-mixin* then treturn four values: t,
SLOTNAME, (quote CLASSNAME), and the class's init-slots. Otherwise
return nil."
(multiple-value-bind (name classname-form)
(ignore-errors ; catch destructuring-bind errors
(destructuring-bind (name &key ((:type classname-form)) &allow-other-keys)
(if (oddp (length form)) ; is (cdr form) currently a well-formed plist?
form
(butlast form))
(values name classname-form)))
;; CLASSNAME-FORM destructures as 'CLASSNAME.
(let ((classname (when (and (listp classname-form)
(eq (car classname-form) 'quote))
(cadr classname-form))))
(multiple-value-bind (proceed input-slots)
(class-input-slots classname)
(values proceed name classname-form input-slots)))))
(defun class-input-slots (classname)
"Use message-list on a prototype instance of CLASSNAME to determine its
required and optional input-slots. Return two values: t and the slots.
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*))))
(let ((prototype (gendl:make-self classname)))
(values t
(append (gendl:the-object prototype (message-list :category :required-input-slots))
(remove-if (lambda (keyword)
(let ((symbol-name (symbol-name keyword)))
(and (char= (schar symbol-name 0) #\%)
(char= (schar symbol-name (1- (length symbol-name))) #\%))))
(gendl:the-object prototype (message-list :category :optional-input-slots))))))))
;; 9. UTILITIES
;; 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.
(defun active-keyword (list)
(let ((key nil)
(stuff nil))
(loop (setf key (pop list))
(if list
(setf stuff (pop list))
(return-from active-keyword
nil))
(unless list
(return)))
(when (listp stuff)
(values key stuff))))
(defun test-active-keyword ()
(loop for (list . result) in '((() . nil)
((:foo) . nil)
((:foo bar) . nil)
((:foo (bar)) . (:foo (bar)))
((:foo (bar) :baz) . nil)
((:foo (bar) :baz ()) . (:baz nil))
)
do
(multiple-value-bind (keyword stuff)
(active-keyword list)
(if keyword
(assert (equal (list keyword stuff) result))
(null result)))))
(test-active-keyword)
;; A. REFERENCES
;;
;;
;; B. HISTORY
;;
;; 2013-05-02 NDL Created.
;;
;; 2013-05-09 NDL Version 0.1 as http://paste.lisp.org/display/137088
;;
;; 2013-05-10 NDL Added *gendl-slime-release*.
;; Release 0.1.1
;;
;;
;; C. COPYRIGHT
;;
;; Copyright 2013 Genworks International
;;
;; This source file is part of the General-purpose Declarative
;; Language project (GDL).
;;
;; This source file contains free software: you can redistribute it
;; and/or modify it under the terms of the GNU Affero General Public
;; License as published by the Free Software Foundation, either
;; version 3 of the License, or (at your option) any later version.
;;
;; This source file is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;; Affero General Public License for more details.
;;
;; You should have received a copy of the GNU Affero General Public
;; License along with this source file. If not, see
;; <http://www.gnu.org/licenses/>.
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