Commit 0f7867a1 authored by Dave Cooper's avatar Dave Cooper
Browse files

Merge pull request #116 from nicklevine/slime-devel

Slime devel: sequence messages, (incomplete) function forms.
parents a389529c af4db9c0
......@@ -11,7 +11,8 @@ bin
*.log
*.toc
configure.el
systems.txt
# Ignore (generated) html files,
# *.html
......
......@@ -9,24 +9,24 @@
;; 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/>.
;;
;;
(in-package :gdl)
(defparameter *features-to-initialize* (list :base :glisp :geom-base :gwl
(defparameter *features-to-initialize* (list :base :glisp :geom-base :gwl
:gwl-graphics :tasty :yadd :robot :cl-lite))
(defun start-gendl! (&key (features *features-to-initialize*)
(defun start-gendl! (&key (features *features-to-initialize*)
(banner? t) (init-files? t))
(dolist (feature features)
;;
......@@ -37,12 +37,12 @@
(let ((package feature))
(if (and (find-package package) (glisp:featurep feature))
(let ((function-sym (read-from-string (format nil "~a::initialize" package))))
(when (fboundp function-sym)
(when (fboundp function-sym)
(let ((description (glisp:package-documentation package)))
(format t "~&Initializing ~a subsystem...~%" description)
(let ((anything-changed? (funcall function-sym)))
(format t "~&...Done~a~%"
(if anything-changed? "."
(if anything-changed? "."
(format nil " (no new global settings).")))))))
(format t "~&Note: Feature ~s does not appear to be loaded at this time.~%" feature))))
(when banner? (startup-banner))
......@@ -68,34 +68,30 @@
(defun startup-banner ()
#+lispworks
(format t "Welcome to Gendl on LispWorks where we can't print wide chars at the moment.")
#-lispworks
(format t
"
Welcome to Gendl™
Copyright© 2002-2013, Genworks International, Birmingham MI, USA.
Copyright© 2002-2013, Genworks International, Birmingham MI, USA.
All Rights Reserved.
This program 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 program 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 the source code for this program. If not, see:
http://www.gnu.org/licenses/
"))
......
......@@ -2,14 +2,36 @@
(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
:width (the text-view width)
:length (the text-view length)
:robot-width (the robot-assembly height)
:robot-length (the robot-assembly length)
:arm-angle-left (the robot-assembly arm-angle-left)
:head-angle (the robot-assembly head-angle)
:body-angle (the robot-assembly body-angle)))
:objects
((tri-view :type 'base-view
((text-view :type 'base-view
:left-margin 0
:front-margin 0
:border-box? t
:objects (list (the text-block))
:length (half (the length))
:width (half (the width))
:projection-vector (getf *standard-views* :top)
:center (translate (the center) :rear (half (the-child length))
:right (half (the-child width))))
(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)))
:width (half (the width))
:center (translate (the center) :rear (half (the-child length))
:left (half (the-child width)))
:projection-vector (getf *standard-views* :trimetric))
(top-view :type 'base-view
......@@ -60,7 +82,26 @@
))
(define-object robot-text-block (typeset-block)
:input-slots
(robot-width robot-length body-angle arm-angle-left head-angle)
:functions
((content
()
(tt:compile-text (:font "Helvetica" :font-size 12.0)
(tt:vspace 100)
(tt:paragraph () "Robot Data")
(tt:table (:col-widths (list 220 (- (the width) 220)))
(dolist (slot (list :robot-width :robot-length :body-angle :arm-angle-left :head-angle))
(tt:row ()
(tt:cell (:background-color "#00FF00") (tt:put-string (format nil "~a" (string-capitalize slot))))
(tt:cell ()
(tt:paragraph (:h-align :center) (tt:put-string (format nil "~a" (the (evaluate slot)))))))))))))
......
......@@ -108,7 +108,7 @@
(defun gendl-quit () (interactive) (gdl-quit))
;; 4.2. Configure slime
;; 4.2. Locate Common Lisp / Locate SLIME
;;
;; Where is our Common Lisp implementation? Where is slime-helper.el?
;; Loading the latter means we can load slime-autoloads.el (which
......@@ -136,6 +136,7 @@
(slime-setup '(slime-fancy slime-banner))
(add-hook 'slime-connected-hook 'load-gendl t)
(add-hook 'slime-connected-hook 'set-slime-shortcuts)
(add-hook 'slime-connected-hook 'customise-slime)
(add-hook 'slime-repl-mode-hook 'remove-dos-eol)
(add-to-list 'auto-mode-alist '("\\.cl\\'" . lisp-mode))
(add-to-list 'auto-mode-alist '("\\.gdl\\'" . lisp-mode))
......@@ -154,6 +155,9 @@
(global-set-key "\C-x&" '(lambda()(interactive) (switch-to-buffer (slime-repl-buffer))))
(global-set-key "\C-x*" '(lambda()(interactive) (switch-to-buffer "*inferior-lisp*"))))
(defun customise-slime ()
(setq slime-autodoc-use-multiline-p t))
(defun remove-dos-eol ()
"Do not show ^M in files containing mixed UNIX and DOS line endings."
(interactive)
......
......@@ -24,14 +24,14 @@
;; This document is not confidential. See end for copyright
;; information.
(defparameter *gendl-slime-release* "0.1.0")
(defparameter *gendl-slime-release* "0.1.1")
;; 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" "empty" nil ":objects" ("" %cursor-marker%))
;; ->
;; "(define-object name mixin-list &key ===> objects <=== &allow-other-keys)"
......@@ -96,6 +96,16 @@
(test-def-wrap)
;; 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.
(defmacro handling-whatever ((&rest options) &body body)
(declare (ignore options))
`(handler-bind ((serious-condition (lambda (condition)
;; Print the problem and decline to handle.
(format *terminal-io* "~&;; Error: ~a~%" condition))))
,@body))
;; 4. ADVISE SWANK FUNCTIONS
;;
......@@ -133,12 +143,17 @@
(let ((*grovelling-for-arglist* t))
(punt form)))
;; This might be useful further down.
(defvar *form-with-arglist*)
;; 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)))
(handling-whatever ()
(let ((*form-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
......@@ -349,17 +364,259 @@
(let ((class (find-class classname nil)))
(when class
(subtypep class 'gendl:vanilla-mixin*))))
(let ((prototype (gendl:make-self classname)))
(let ((prototype (gendl-class-prototype 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))) #\%))))
(remove-if 'internal-name-p
(gendl:the-object prototype (message-list :category :optional-input-slots))))))))
(defun gendl-class-prototype (class)
"We could access the lisp implementation's CLOS class-prototype, but
can't expect that to have any boundp slots. For some of our uses that
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)))))
(defun internal-name-p (keyword)
(let ((symbol-name (symbol-name keyword)))
(and (char= (schar symbol-name 0) #\%)
(char= (schar symbol-name (1- (length symbol-name))) #\%))))
;; 9. HELP ON MESSAGES FOR GENDL:THE AND FRIENDS
;; We're only looking at the top of the reference-chain. See
;; http://paste.lisp.org/display/137274
;; Note that (the (slot-source :bar)) gives you info about the
;; specified :type of bar. "You also have to establish the fact that
;; bar is indeed a GDL object and not some leaf-level value as with a
;; computed-slot (like a string or number). That can be done with
;; :return-category t."
(defparameter *message-locators*
'(messages-in-this-form
messages-from-classes)
"A list of functions, each taking a (gendl:define-object ...) form,
each returning a list of proposed messages.")
(defmethod compute-enriched-decoded-arglist ((operator (eql 'gendl:the)) arguments)
(declare (ignorable arguments))
(or (embedded-the-arglist) (call-next-method)))
(defmethod compute-enriched-decoded-arglist ((operator (eql 'gendl:the-object)) arguments)
(declare (ignorable arguments))
(or (embedded-the-arglist) (call-next-method)))
(defmethod compute-enriched-decoded-arglist ((operator (eql 'gendl:the-child)) arguments)
(declare (ignorable arguments))
(or (embedded-the-arglist) (call-next-method)))
(defun embedded-the-arglist ()
(let* ((whole-form *form-with-arglist*)
(*this-the* (this-the-from-form whole-form))
(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
(values (make-arglist :key-p t
:keyword-args (loop for message in messages collect
(make-keyword-arg message message nil))
:provided-args nil
:allow-other-keys-p t
: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))))
(quantifiedp (quantified-objects-p section slot-form the-form)))))
section
slot-form
the-form
functionp
quantifiedp)
(defun quantified-objects-p (section slot-form the-form)
(and (case section
((objects hidden-objects) t))
(destructuring-bind (operator &rest more)
the-form
(declare (ignore more))
(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)))))))
(defvar *this-the*)
;; 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.
(destructuring-bind (classname &optional mixins
&key input-slots computed-slots objects hidden-objects functions methods
&allow-other-keys)
(cdr form)
(declare (ignore classname mixins))
(loop for section in (list input-slots computed-slots objects hidden-objects functions methods)
as section-name in '(input-slots computed-slots objects hidden-objects functions methods)
do
(loop for item in section
when (consp item)
do
(let ((form-with-cursor-marker (form-with-cursor-marker item)))
(when form-with-cursor-marker
(return-from this-the-from-form
(make-this-the section-name item form-with-cursor-marker))))))))
(defun form-with-cursor-marker (form)
;; Return, if any, the innermost (the ...) form containing the
;; cursor-marker.
(loop for thing in form
do
(cond ((eq thing '%cursor-marker%) (return form))
((consp thing)
(let ((inner-form (form-with-cursor-marker thing)))
(when inner-form
(if (and (consp inner-form)
(case (car inner-form)
((gendl:the gendl:the-child gendl:the-object) t)))
(return inner-form)
(return thing))))))))
;; 9.2. Messages which we can deduce from the current form.
(defun messages-in-this-form (form)
"Do what define-object itself does, to figure out the messages being
defined by this form. As a side effect, set *this-the* to the
gendl:the (etc) form under construction."
(destructuring-bind (classname &optional mixins
&key input-slots computed-slots objects hidden-objects functions methods
&allow-other-keys)
(cdr form)
(declare (ignore classname mixins))
;; [logic lifted from gendl::with-gdl-message-symbols]
(loop for section in (list input-slots computed-slots objects hidden-objects functions methods)
append
(with-buffer-syntax ()
(let ((keyword (find-package :keyword)))
(loop for item in section
for symbol = (cond ((symbolp item) item)
((consp item) (unless (form-with-cursor-marker item)
;; Exclude the message we're in the process of creating.
(let ((first (gendl::first-symbol item)))
(typecase first
(symbol first)
(arglist-dummy (from-string (arglist-dummy.string-representation first))))))))
when symbol
collect
(if (eq (symbol-package symbol) keyword)
symbol
(intern (symbol-name symbol) keyword))))))))
;; 9.3. Messages which we can deduce from mixin classes.
(defparameter *messages-to-suppress*
(list :aggregate :all-mixins :children-uncached :direct-mixins :documentation
:hidden? :leaves-uncached :message-documentation :message-list :mixins :name-for-display
: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))
(defparameter *messages-to-suppress-when-not-sequence-member*
(list :first? :index :last?))
(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)))))
(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)))
:from-end t))
(messages (remove-duplicates (loop for class in mixins
append (sort (messages-from-class class)
'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) nil)
;; [gendl] make your own defparameter for now, but flag it that it
;; might be redundant with something we already have defined
(defparameter *internal-packages*
(loop for designator in
'(:gendl :geom-base :surf :gwl :yadd :tasty)
collect
(find-package designator)))
(defun messages-from-class (class)
"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))
(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*)
(null (gendl:the-object prototype (message-remarks keyword))))))
:normal)))))
;; 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
(defun filter-sequence-messages (messages)
(if (and (boundp '*this-the*)
(this-the-quantifiedp *this-the*))
messages
;; Again, we preserve order
(loop for message in messages
unless (find message *messages-to-suppress-when-not-sequence-member*)
collect message)))
;; 9. UTILITIES
;; 10. 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.
......@@ -395,7 +652,6 @@
(test-active-keyword)
;; A. REFERENCES
;;
;;
......
(in-package :asdf)
(defsystem #:gendl
:description "The Gendl Project"
:author "Dave Cooper <david.cooper@genworks.com>"
:license "Affero Gnu General Public License (please see http://www.gnu.org/licenses/)"
:serial t
#+asdf-encoding :encoding #+asdf-encoding :utf-8
:version "2013031600"
:depends-on (:cl-lite :gwl-graphics :tasty :robot :yadd))
(defmethod perform :after ((op load-op) (system (eql (find-system "gendl"))))
(declare (ignore op))
;; Check whether GENDL has been configured yet.
(multiple-value-bind (found ignore system-pathname)
(locate-system system)
(declare (ignore ignore))
(if found
(let ((config-file (merge-pathnames "configure.el" system-pathname)))
(unless (probe-file config-file)
;; Looks like this is the first time around.
(configure-gendl config-file)))
(warn "ASDF cannot locate the GENDL which it just loaded. Further configuration not possible."))))
(defparameter *setup-gendl-template* "
;; CONFIGURE.EL
;;
;; The purpose of this document is to configure (a) the lisp
;; invocation to be used for running GENDL and (b) the location of
;; your quicklisp installation.
;;
;; This file will be written automatically when the GENDL system is
;; loaded for the first time. You may edit it yourself but do take
;; care: the file is loaded by both EMACS and Common Lisp. We suggest
;; you don't add any other forms to the file.~@{~2%~s~}")
(defparameter *setup-emacs-template* "
*********************************************************************
To configure your EMACS to work with GENDL, add the following to your
.emacs file:
(defun start-gendl () (interactive) (load ~s))
;; (global-set-key [f10] 'start-gendl)
")
(defun configure-gendl (config-file)
(unless (probe-file config-file)
(let ((lisp-invocation (funcall (find-symbol (string 'basic-command-line-arguments) :glisp)))
(path-to-quicklisp-helper (ql-setup:qmerge "slime-helper.el")))
;; This is unfortunate. Clozure won't give you the heap name
;; unless you chase after it specifically.
#+:ccl
(let ((heap ccl:*heap-image-name*))
(setf lisp-invocation `(,(car lisp-invocation) "-I" ,heap ,@(cdr lisp-invocation))))
;; 1. Write the config file.
(with-open-file (out config-file :direction :output)
(let ((*package* (find-package :common-lisp-user))
(*print-case* :downcase))
(format out *setup-gendl-template*
`(setq ,'cl-user::lisp-invocation ',lisp-invocation)
`(setq ,'cl-user::path-to-quicklisp-helper ,(namestring path-to-quicklisp-helper)))))
;; 2. Download quicklisp-slime-helper
(let* (;; We intend to overwrite the default output from quicklisp-slime-helper:install
(standard-output *standard-output*)
(*standard-output* (make-broadcast-stream)))
(handler-bind ((serious-condition (lambda (e) (declare (ignore e)) (setf *standard-output* standard-output))))
(ql:quickload :quicklisp-slime-helper)))
;; 3. Add GENDL-loading form to .emacs
(let ((path-to-gdl-loader (merge-pathnames "emacs/gdl.el" config-file)))
(format t *setup-emacs-template* (namestring path-to-gdl-loader)))
config-file)))
(in-package :asdf)
(defsystem #:gendl
:description "The Gendl Project"
:author "Dave Cooper <david.cooper@genworks.com>"
:license "Affero Gnu General Public License (please see http://www.gnu.org/licenses/)"
:serial t
#+asdf-encoding :encoding #+asdf-encoding :utf-8
:version "2013031600"
:depends-on (:cl-lite :gwl-graphics :tasty :robot :yadd))
(defmethod perform :after ((op load-op) (system (eql (find-system "gendl"))))
(declare (ignore op))
;; Check whether GENDL has been configured yet.
(multiple-value-bind (found ignore system-pathname)
(locate-system system)
(declare (ignore ignore))