Commit 0364f783 authored by Dave Cooper's avatar Dave Cooper

ready for fresh dev install

parent cef7a134
(in-package :gdl-user) (in-package :gdl-user)
(define-object robot-drawing (base-drawing) (define-object robot-drawing (base-drawing)
:hidden-objects ((robot-assembly :type 'robot:assembly) :hidden-objects ((robot-assembly :type 'robot:assembly)
(text-block :type 'robot-text-block (text-block :type 'robot-text-block
...@@ -17,7 +17,7 @@ ...@@ -17,7 +17,7 @@
:objects :objects
((text-view :type 'base-view ((text-view :type 'base-view
;;:left-margin 0 ;;:left-margin 0
;;:front-margin 0 ;;:front-margin 0
:border-box? t :border-box? t
...@@ -26,7 +26,7 @@ ...@@ -26,7 +26,7 @@
:width (half (the width)) :width (half (the width))
:projection-vector (getf *standard-views* :top) :projection-vector (getf *standard-views* :top)
:center (translate (the center) :rear (half (the-child length)) :center (translate (the center) :rear (half (the-child length))
:right (half (the-child width)))) :right (half (the-child width))))
(tri-view :type 'base-view (tri-view :type 'base-view
:border-box? t :border-box? t
...@@ -98,6 +98,7 @@ ...@@ -98,6 +98,7 @@
(tt:vspace 100) (tt:vspace 100)
(tt:paragraph () "Robot Data") (tt:paragraph () "Robot Data")
(let ((width (- (the width) (the margins)))) (let ((width (- (the width) (the margins))))
(tt:table (:col-widths (list (* 2/3 width) (* 1/3 width))) (tt:table (:col-widths (list (* 2/3 width) (* 1/3 width)))
(dolist (slot (list :robot-width :robot-length :body-angle :arm-angle-left :head-angle)) (dolist (slot (list :robot-width :robot-length :body-angle :arm-angle-left :head-angle))
......
...@@ -16,7 +16,7 @@ ...@@ -16,7 +16,7 @@
;; 2. WHERE ARE WE? ;; 2. WHERE ARE WE?
(defvar *gdl-home* (file-truename (concat (file-name-directory (file-truename load-file-name)) "../"))) (defvar *gendl-home* (file-truename (concat (file-name-directory (file-truename load-file-name)) "../")))
;; 3. CONFGURGE EMACS ;; 3. CONFGURGE EMACS
...@@ -39,7 +39,7 @@ ...@@ -39,7 +39,7 @@
;; 3.2. Set up color-theme and solarized color-themes ;; 3.2. Set up color-theme and solarized color-themes
(add-to-list 'load-path (concat *gdl-home* "emacs/emacs-color-theme")) (add-to-list 'load-path (concat *gendl-home* "emacs/emacs-color-theme"))
(require 'color-theme) (require 'color-theme)
(color-theme-initialize) (color-theme-initialize)
(color-theme-sitaramv-solaris) (color-theme-sitaramv-solaris)
...@@ -100,8 +100,9 @@ ...@@ -100,8 +100,9 @@
;; ;;
;; 4.1. Some synonyms ;; 4.1. Some synonyms
(defun gendl () (interactive) (with-temp-buffer (cd *gdl-home*) (slime))) (defun gendl () (interactive) (with-temp-buffer (cd *gendl-home*) (slime)))
(defun gdl () (interactive) (gendl)) (defun gdl () (interactive) (gendl))
(defun glime () (interactive) (gendl))
(defun gdl-quit () (interactive) (slime-quit-lisp)) (defun gdl-quit () (interactive) (slime-quit-lisp))
(defun gq () (interactive) (gdl-quit)) (defun gq () (interactive) (gdl-quit))
...@@ -117,13 +118,15 @@ ...@@ -117,13 +118,15 @@
(defun configure-slime () (defun configure-slime ()
(setq lisp-invocation nil) (setq lisp-invocation nil)
(setq path-to-quicklisp-helper nil) (setq path-to-quicklisp-helper nil)
(let ((config-file (concat *gdl-home* "configure.el"))) (let ((config-file (concat *gendl-home* "configure.el")))
(when (file-exists-p config-file) (if (file-exists-p config-file)
;; Loading this file sets lisp-invocation and path-to-quicklisp-helper (progn
(load-file config-file)) ;; Loading this file sets slime-lisp-implementations and path-to-quicklisp-helper
(when lisp-invocation (load-file config-file)
(setq slime-lisp-implementations `((gendl ,lisp-invocation)))) (load-file path-to-quicklisp-slime-helper))
(load-file path-to-quicklisp-helper))) (error "Config File %s was not found.
Please create this file, which should set slime-lisp-implementations and path-to-quicklisp-slime-helper."))))
(configure-slime) (configure-slime)
(require 'slime-autoloads) (require 'slime-autoloads)
...@@ -144,7 +147,7 @@ ...@@ -144,7 +147,7 @@
(defun load-gendl () (defun load-gendl ()
(slime-repl) (slime-repl)
(insert (format "(load \"%sload-gendl.lisp\")" *gdl-home*)) (insert (format "(load \"%sload-gendl.lisp\")" *gendl-home*))
(insert "(in-package gdl-user)") (insert "(in-package gdl-user)")
(slime-repl-return) (slime-repl-return)
(end-of-buffer)) (end-of-buffer))
...@@ -168,14 +171,11 @@ ...@@ -168,14 +171,11 @@
;; 4.4. Prior to SLIME ;; 4.4. Prior to SLIME
(defun prior-to-slime () (defun prior-to-slime ()
(find-file (concat *gdl-home* "emacs/README.txt")) (find-file (concat *gendl-home* "emacs/README.txt"))
(toggle-read-only) (toggle-read-only)
(let ((frame-title "Genworks® Gendl™ Interactive Authoring Environment")) (let ((frame-title "Genworks® Gendl™ Interactive Authoring Environment"))
(modify-frame-parameters nil (modify-frame-parameters nil (list (cons 'name frame-title))))
(list (cons 'name frame-title)))) (when (file-exists-p "~/.emacs-gendl") (load-file "~/.emacs-gendl"))
(message "Please see the Startup section of this document for starting the Gendl environment.")
(when (file-exists-p "~/.emacs-gendl")
(load-file "~/.emacs-gendl"))
(setq inhibit-splash-screen t) (setq inhibit-splash-screen t)
(cd "~/") (cd "~/")
(set-frame-parameter nil 'fullscreen 'maximized)) (set-frame-parameter nil 'fullscreen 'maximized))
...@@ -184,7 +184,7 @@ ...@@ -184,7 +184,7 @@
;; 5. MAKE IT HAPPEN ;; 5. MAKE IT HAPPEN
(prior-to-slime) (prior-to-slime)
(slime) (glime)
;; A. REFERENCES ;; A. REFERENCES
......
1. Reference-chains entered into Slime REPL throw an "error in process 1. Reference-chains (with "the" or "the-object") entered into Slime
filter" e.g.: REPL (or anywhere else outside of a define-object context) should
still provide an enriched-decoded-arglist in the mini-buffer, iff
the global gdl:self is bound (which it typically will be, if
someone is typing reference chains at Slime REPL).
GDL-USER> In that case, the global gdl:self should be the starting class for
;; Error: Odd length keyword list: (SWANK::%CURSOR-MARKER%) any reference chains.
;; Error: Odd length keyword list: (SWANK::%CURSOR-MARKER%)
;; Error: Odd length keyword list: (SWANK::%CURSOR-MARKER%)
; No value
GDL-USER> (the foo ...
example:
This is fixed temporarily with an ignore-errors around body of
this-the-from-form in emacs/glime.lisp genworks' current
slime-devel branch. Ignore-errors should probably still be there GDL-USER> (make-self 'robot-drawing)
just to catch any unforeseen situations, but probably with a #<ROBOT-DRAWING #x302004739C4D>
multiple-value-bind to catch the error and handle it somehow or at GDL-USER> (the
least print a warning message about it.
Now the mini-buffer should show completions of "(the ..." based
on the fact that self is an instance of robot-drawing.
N.B. self is not declared special in Gendl currently. It probably
should be, but I am not sure what would be the ramifications of
doing this. Needs to be investigated (on my end). For now it
should be left as-is and not declared special with defparameter or
defvar.
2. Within the-child and the-object, glime was incorrectly picking up
the messages-in-this-form as well as the messages from the :type of
the current child object. This has been fixed for now by binding
*message-locators* to simply '(messages-from-classes) in
compute-enriched-decoded-arglist for the-object and the-child. I'm
not sure if this is the best way to go about this, because there is
another case where messages-in-this-form should not be included
(see (3) below).
2. the-child is not picking up the type of current child -- it still 3. In reference-chains after the first message, i.e.
appears to be working based off the enclosing define-object type.
3. When placing the "(" after "(the (" it does toggle to display (the foo ...)
available GDL Functions, but it should also suppress display of
non-Function slots, and it does not appear to be doing this. it is still picking up messages-in-this-form. At that point it
should only be picking up messages-from-classes for the class-of
(the foo) [if any].
4. Sequence (quantified) objects are still showing up for "(the ..."
and they should only show up for "(the (..." [i.e. they should
behave like Functions]
example:
(define-object frob ()
:objects ((baz :type 'box
:sequence (:size 10))))
;; compile above form. Now do
(make-self 'frob)
(the ...
4. slime-autodoc-use-multiline-p does not appear to be activated. Typing "(the ..." should not include baz
5. Sequence (quantified) objects are not behaving like GDL Functions Typing "(the (..." _should_ include baz.
for "(the (" as they should.
6. Reference-chains do not appear to pick up the inferred type of each
element along the chain, as theoretically should (at least
sometimes) be possible, using e.g. (the (slot-source ...)) and
pulling out the :type for messages which name :objects
or :hidden-objects.
7. Functions-in-this-form (which are not compiled into object yet) are
not being picked up.
8. a. "(the-object foo (evaluate ... " should work identically to 5. a. "(the-object foo (evaluate ... " should work identically to
"(the-object foo ..." except symbols should show up as keywords. "(the-object foo ..." except symbols should show up as keywords.
b. "(the-object foo ((evaluate ... " should work identically to b. "(the-object foo ((evaluate ... " should work identically to
......
...@@ -432,11 +432,13 @@ each returning a list of proposed messages.") ...@@ -432,11 +432,13 @@ each returning a list of proposed messages.")
(defmethod compute-enriched-decoded-arglist ((operator (eql 'gendl:the-object)) arguments) (defmethod compute-enriched-decoded-arglist ((operator (eql 'gendl:the-object)) arguments)
(declare (ignorable arguments)) (declare (ignorable arguments))
(or (embedded-the-arglist) (call-next-method))) (let ((*message-locators* '(messages-from-classes)))
(or (embedded-the-arglist) (call-next-method))))
(defmethod compute-enriched-decoded-arglist ((operator (eql 'gendl:the-child)) arguments) (defmethod compute-enriched-decoded-arglist ((operator (eql 'gendl:the-child)) arguments)
(declare (ignorable arguments)) (declare (ignorable arguments))
(or (embedded-the-arglist) (call-next-method))) (let ((*message-locators* '(messages-from-classes)))
(or (embedded-the-arglist) (call-next-method))))
(defvar *this-the*) (defvar *this-the*)
...@@ -446,6 +448,7 @@ each returning a list of proposed messages.") ...@@ -446,6 +448,7 @@ each returning a list of proposed messages.")
;; The gend:the form isn't embedded inside a define-object. Bail out. ;; The gend:the form isn't embedded inside a define-object. Bail out.
(return-from embedded-the-arglist (return-from embedded-the-arglist
nil)))) nil))))
(when-let (messages (when (and (consp whole-form) (when-let (messages (when (and (consp whole-form)
(eq (car whole-form) 'gendl:define-object)) (eq (car whole-form) 'gendl:define-object))
(remove-duplicates (loop for locator in *message-locators* append (remove-duplicates (loop for locator in *message-locators* append
...@@ -463,11 +466,11 @@ each returning a list of proposed messages.") ...@@ -463,11 +466,11 @@ each returning a list of proposed messages.")
;; 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 (when (consp the-form) (functionp (when (consp the-form)
(the-form-functionp (cdr the-form)))) (the-form-functionp (cdr 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
the-form the-form
...@@ -571,18 +574,25 @@ gendl:the (etc) form under construction." ...@@ -571,18 +574,25 @@ gendl:the (etc) form under construction."
;; 9.3. Messages which we can deduce from mixin classes. ;; 9.3. Messages which we can deduce from mixin classes.
(defparameter *messages-to-suppress* (defparameter *messages-to-suppress*
(list :aggregate :all-mixins :children-uncached :direct-mixins :documentation (list
:hidden? :leaves-uncached :message-documentation :message-list :mixins :name-for-display ;; from vanilla-mixin*:
:restore-all-defaults! :restore-tree! :root :root-path-local :root? :safe-children :aggregate :all-mixins :children-uncached :direct-mixins :documentation
:safe-hidden-children :slot-documentation :slot-source :slot-status :update! :visible-children :hidden? :leaves-uncached :message-documentation :message-list :mixins :name-for-display
:write-snapshot)) :restore-all-defaults! :restore-tree! :root :root-path-local :root? :safe-children
:safe-hidden-children :slot-documentation :slot-source :slot-status :update! :visible-children
:write-snapshot
;; from base-object:
:image-file :local-bbox :local-box :local-center :local-center*
:local-orientation :obliqueness
))
(defparameter *messages-to-suppress-when-not-sequence-member* (defparameter *messages-to-suppress-when-not-sequence-member*
(list :first? :index :last?)) (list :first? :index :last? :next :previous))
(defun messages-from-classes (form)
(defun messages-from-classes* (classes)
"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 (starting-classes form)) (let* ((starting-classes classes)
(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)))
...@@ -592,6 +602,12 @@ gendl:the (etc) form under construction." ...@@ -592,6 +602,12 @@ gendl:the (etc) form under construction."
'string<))))) 'string<)))))
(filter-sequence-messages messages))) (filter-sequence-messages messages)))
(defun messages-from-classes (form)
"Use message-list to find out what the messages might be."
(let ((starting-classes (starting-classes form)))
(messages-from-classes* starting-classes)))
(defun starting-classes (form) (defun starting-classes (form)
(destructuring-bind (classname &optional mixins &rest keywords) (destructuring-bind (classname &optional mixins &rest keywords)
(cdr form) (cdr form)
...@@ -602,10 +618,10 @@ gendl:the (etc) form under construction." ...@@ -602,10 +618,10 @@ gendl:the (etc) form under construction."
;; It's a either a (the-child ...) class , or a redefinition ;; It's a either a (the-child ...) class , or a redefinition
;; (which includes: clicking on an existing defintion). ;; (which includes: clicking on an existing defintion).
(the-reference-chain this-class) (the-reference-chain this-class)
;; New definition. Hit the superclasses. ;; New definition. Hit the superclasses.
(loop for classname in mixins (loop for classname in mixins
for class = (safe-find-class classname) for class = (safe-find-class classname)
when class collect class))))) when class collect class)))))
;; If we're in a the-child inside an :objects or :hidden-objects clause and can find ;; If we're in a the-child inside an :objects or :hidden-objects clause and can find
;; a class for the :type, return that. ;; a class for the :type, return that.
...@@ -699,6 +715,7 @@ in one of the *internal-packages*), otherwise filter for non-nil message-remarks ...@@ -699,6 +715,7 @@ in one of the *internal-packages*), otherwise filter for non-nil message-remarks
collect message))))) 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
......
(in-package :common-lisp-user)
(let ((personal-boot-file "../gdl/tools/boot/load.lisp"))
(when (probe-file personal-boot-file) (load personal-boot-file)))
(funcall (find-symbol (string #:quickload) :ql) :gendl)
(gendl:start-gendl!)
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