Commit 7efae6ec authored by Dave Cooper's avatar Dave Cooper

Merge pull request #115 from nicklevine/slime-devel

First crack at support for gendl::the.  Also: enable slime-autodoc-use-multiline-p; git must ignore configure.el; fix *gendl-slime-release* (wrong at last release, alas); fix line-endings in gendl.asd (for some reason, git fixes these for me for .el and .
parents 755d4a7a c96adba1
......@@ -11,7 +11,7 @@ bin
*.log
*.toc
configure.el
# 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/
"))
......
......@@ -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)"
......@@ -133,12 +133,16 @@
(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)))
(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 +353,154 @@
(let ((class (find-class classname nil)))
(when class
(subtypep class 'gendl:vanilla-mixin*))))
(let ((prototype (gendl:make-self classname)))
(let ((prototype (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))))))))
;; 9. UTILITIES
(defun class-prototype (class)
"Install the correct defintion of class-prototype and invoke it, if we
can. Otherwise, fall back on make-self."
(let* ((package-designator ;; list heaved out of closer-mop-packages.lisp
#+abcl :ext
#+allegro :excl
#+clozure :ccl
#+cmu :pcl
#+ecl :clos
#+lispworks :clos
#+mcl :ccl
#+sbcl :sb-pcl)
(class-prototype (when package-designator
(find-symbol (string 'class-prototype) package-designator))))
(if class-prototype
(progn
(setf (symbol-function 'class-prototype)
(symbol-function class-prototype))
(funcall class-prototype class))
(or (get 'class-prototype 'instance)
(setf (get 'class-prototype 'instance)
(gendl:make-self 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 THE
(defmethod compute-enriched-decoded-arglist ((operator (eql 'gendl:the)) arguments)
(let* ((whole-form *form-with-arglist*)
(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))))
(if messages
(values (make-arglist :key-p t
:keyword-args (loop for message in messages collect
(make-keyword-arg message message nil))
:provided-args nil
:rest 'reference-chain)
nil t)
(call-next-method))))
(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.")
(defun messages-in-this-form (form)
"Do what define-object itself does, to figure out the messages being
defined by this form."
(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 ;; Exclude the message we're in the process of creating.
(form-contains-cursor-marker item)
(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))))))))
(defun form-contains-cursor-marker (form)
(loop for thing in form
when (or (eq thing '%cursor-marker%)
(and (consp thing)
(form-contains-cursor-marker thing)))
do (return t)))
(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 (find-class classname nil)))
(if this-class
;; It's a redefinition
(list this-class)
;; New definition. Hit the superclasses.
(loop for classname in mixins
for class = (find-class classname nil)
when class collect class)))))
(mixins (remove-duplicates (loop for class in starting-classes append
(gendl:the-object (gendl:make-self class) all-mixins))
:from-end t))
(messages (remove-duplicates (loop for class in mixins
append (messages-from-class class)))))
(sort (copy-list messages)
'string<)))
;; [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)))
(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))
(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 (class-prototype class)))
(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))))))
;; 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 +536,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))
(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)))
......@@ -56,7 +56,7 @@
;; 3. Load gendl plus dependencies.
(funcall (find-symbol "QUICKLOAD" "QL") :gendl)
(funcall (find-symbol (string 'quickload) :ql) :gendl)
;; 4. Load the slime integration. Ideally this should be done
;; (conditionally) by the quickload above.
......@@ -64,9 +64,16 @@
#+:swank
(load (compile-file (merge-pathnames "emacs/gendl.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
(setf (slot-value *standard-output* 'swank-backend::buffer)
(coerce (slot-value *standard-output* 'swank-backend::buffer)
'lw:simple-text-string))
;; 5. Start gendl.
(let ((starter (find-symbol "START-GENDL!" "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