Commit 27a2d98b authored by Dave Cooper's avatar Dave Cooper

started adding defgenerics to macroexpanded code. Updated Manual. Removed...

started adding defgenerics to macroexpanded code. Updated Manual. Removed debug messages from gdlAjax.
parent 9ba7d68f
Clean startup on Ubuntu Linux (replace apt-get with the package manager
on your local Linux or MacOS):
==============================
$ == Linux shell prompt
* == Common Lisp shell prompt
M- or C- == Meta or Control command inside emacs
# == comment or manual action
$ cd
$ sudo apt-get install git
$ git clone git://gitub.com/genworks/Genworks-GDL.git
$ sudo apt-get install emacs
$ sudo apt-get install sbcl
$ sudo apt-get install curl
$ mkdir ~/cl
$ cd ~/cl
$ curl -O http://beta.quicklisp.org/quicklisp.lisp
$ cd ..
$ sbcl --load cl/quicklisp.lisp
* (quicklisp-quickstart:install)
* (ql:quickload :quicklisp-slime-helper)
# [Edit your .emacs or other emacs startup file as indicated]
* (quit)
$ emacs
M-x slime
* (load "~/quicklisp/setup")
* (pushnew (make-pathname :name nil :type nil
:defaults "~/Genworks-GDL/")
ql:*local-project-directories*)
* (ql:register-local-projects)
* (ql:quickload :gdl-all)
* (ql:quickload :gdl-surf) ;; optional -- provides VRML and X3DOM output - under development!
# [In web browser: visit: http://localhost:9000/tasty]
# [In field for package::class, enter robot:assembly]
# [click pencil icon next to Robot (shows up on mouseover]
......@@ -33,9 +33,18 @@
:objects
((twenty-four :type 'assembly-24
((wind :type 'wind-demo-launcher)
(twenty-four :type 'assembly-24
:pass-down (respondent))))
(define-object wind-demo-launcher (base-site-sheet)
:computed-slots
((right-section-inner-html
(with-cl-who-string ()
"Please click "
((:a :href "/demo-1") "Here")
" to visit the Wind Turbine demo."))))
......@@ -52,7 +52,9 @@ high-end commercial components.")
(:p (:strong "Genworks")
" is the first-level vendor for GenDL. We work with a network of General Resellers and Value-added Resellers to provide
you with customized services and end-user applications, depending on your precise requirements."))
you with customized services and end-user applications, depending on your precise requirements.")
(:p ((:iframe :idth "560" :height "315" :src "http://www.youtube.com/embed/yTcxNaBKTOc?hd=1" frameborder "0" :allowfullscreen "allowfullscreen"))))
(:h3 "Company Profile")
((:div :class "profile")
......
......@@ -58,7 +58,12 @@
(main-sheet-body
(with-cl-who-string ()
(:div :id "wrapper"
(:div :id "header"(:h1 "Wind Turbine Geometry Demo"))
((:div :id "header")
(:center (:h1 "Wind Turbine Geometry Demo")
((:a :href "https://github.com/genworks/Genworks-GDL/tree/master/demos/wind-demo-1/source" :target "_sources")
(:i "source code"))))
(:div :id "left"
(:div :id "logo"
(:h1 "KE-Works S.R.L. & Genworks International")
......@@ -121,7 +126,9 @@
(define-object general-inputs (sheet-section)
:computed-slots
((main-view (with-cl-who-string ()
((max-blades 12)
(main-view (with-cl-who-string ()
((:table :class "input_area")
((:col :width "90%")
(:tr (:td) (:td))
......@@ -143,6 +150,11 @@
:default 3
:prompt nil
:size 1
:validation-function #'(lambda(value) (if (and (integerp value)
(<= 1 value (the max-blades)))
t
(list :validated-value (the-child default) :error "The value must be an integer between 1 and 12, inclusive.")))
:allow-invalid? nil
:ajax-submit-on-change? t)
(hub-hight :type 'text-form-control
......@@ -322,10 +334,11 @@
:computed-slots
((main-view (with-cl-who-string ()
(str (the component-display-control html-string))
#+nil
(:h3 (str (if (eql (the component-display-control value) :rotor-assembly)
"Blade concepts"
"" )))
#+nil
(str (if (eql (the component-display-control value) :rotor-assembly)
(the blade-concepts html-string) ""))
)))
......@@ -345,14 +358,14 @@
(blade-concepts :type 'menu-form-control
:choice-plist (list :classic-blade "Classic blade"
:blade-with-flaps "Blade with flaps"
:blade-with-morfin-tip "Blade with morfin tip"
:blade-with-m-tip-flaps "Blade with M-tip-flaps")
:default :classic-blade
:size 1
:prompt nil
:ajax-submit-on-change? t)
:choice-plist (list :classic-blade "Classic blade"
:blade-with-flaps "Blade with flaps"
:blade-with-morfin-tip "Blade with morfin tip"
:blade-with-m-tip-flaps "Blade with M-tip-flaps")
:default :classic-blade
:size 1
:prompt nil
:ajax-submit-on-change? t)
......
......@@ -218,9 +218,8 @@
(add-hook 'slime-repl-mode-hook 'remove-dos-eol)
(add-to-list 'auto-mode-alist '("\\.gdl\\'" . lisp-mode))
(add-to-list 'auto-mode-alist '("\\.gendl\\'" . lisp-mode))
(add-to-list 'auto-mode-alist '("\\.gendl\\'" . lisp-mode))))
))
;;
;; To switch to slime buffer shortcuts
......
......@@ -2,11 +2,16 @@
;;
;; FLAG -- this will be more useful as a view-scale-independent mixin
;;
(define-object visible-coordinate-system (base-coordinate-system)
:input-slots ((length 10) (width 10) (height 10)
(show-axes? t :settable)
(show-face-labels? t :settable)
(grid-size 10)
(grid-pitch (/ (the length) (the grid-size))))
......@@ -15,7 +20,9 @@
((box :type 'box
:display-controls (list :color :orange :transparency 0.8))
(x-pointer :type 'axis-pointer
:hidden? (not (the show-axes?))
:label "X"
:display-controls (list :color :red)
:length (half (the length))
......@@ -31,6 +38,7 @@
(y-pointer :type 'axis-pointer
:hidden? (not (the show-axes?))
:label "Y"
:display-controls (list :color :green)
:length (half (the length))
......@@ -46,24 +54,28 @@
(z-pointer :type 'axis-pointer
:hidden? (not (the show-axes?))
:label "Z"
:display-controls (list :color :blue)
:length (half (the length))
:orientation (alignment :front (the (face-normal-vector :top))))
(front-label :type 'general-note
:hidden? (not (the show-face-labels?))
:center (the (face-center :front))
:orientation (alignment :top (the (face-normal-vector :front)))
:character-size 3
:strings "Front")
(rear-label :type 'general-note
:center (the (face-center :rear))
:orientation (alignment :top (the (face-normal-vector :rear)))
:character-size 3
:strings "Rear")
:hidden? (not (the show-face-labels?))
:center (the (face-center :rear))
:orientation (alignment :top (the (face-normal-vector :rear)))
:character-size 3
:strings "Rear")
(right-label :type 'general-note
:hidden? (not (the show-face-labels?))
:center (the (face-center :right))
:orientation (alignment :top (the (face-normal-vector :right))
:rear (the (face-normal-vector :top)))
......@@ -71,26 +83,27 @@
:strings "Right")
(left-label :type 'general-note
:center (the (face-center :left))
:orientation (alignment :top (the (face-normal-vector :left))
:rear (the (face-normal-vector :top)))
:character-size 3
:strings "Left")
:hidden? (not (the show-face-labels?))
:center (the (face-center :left))
:orientation (alignment :top (the (face-normal-vector :left))
:rear (the (face-normal-vector :top)))
:character-size 3
:strings "Left")
(top-label :type 'general-note
:center (the (face-center :top))
:orientation (alignment :top (the (face-normal-vector :top)))
:character-size 3
:strings "Top")
:hidden? (not (the show-face-labels?))
:center (the (face-center :top))
:orientation (alignment :top (the (face-normal-vector :top)))
:character-size 3
:strings "Top")
(bottom-label :type 'general-note
:center (the (face-center :bottom))
:orientation (alignment :top (the (face-normal-vector :bottom)))
:character-size 3
:strings "Bottom")
:hidden? (not (the show-face-labels?))
:center (the (face-center :bottom))
:orientation (alignment :top (the (face-normal-vector :bottom)))
:character-size 3
:strings "Bottom")))
))
(define-object axis-pointer (cylinder)
......
......@@ -194,10 +194,10 @@
\newlabel{fig:coord-sys-top}{{7.3}{45}{Coordinate System in Top View\relax }{figure.7.3}{}}
\@writefile{lof}{\contentsline {figure}{\numberline {7.4}{\ignorespaces Coordinate System with Symbolically Labeled Faces}}{45}{figure.7.4}}
\newlabel{fig:coord-sys-labeled-faces}{{7.4}{45}{Coordinate System with Symbolically Labeled Faces\relax }{figure.7.4}{}}
\@writefile{toc}{\contentsline {chapter}{\numberline {8}Custom User Interfaces in GenDL}{47}{chapter.8}}
\@writefile{toc}{\contentsline {chapter}{\numberline {8}Custom User Interfaces in Gendl}{47}{chapter.8}}
\@writefile{lof}{\addvspace {10\p@ }}
\@writefile{lot}{\addvspace {10\p@ }}
\newlabel{chap:customuserinterfacesingendl}{{8}{47}{Custom User Interfaces in GenDL\relax }{chapter.8}{}}
\newlabel{chap:customuserinterfacesingendl}{{8}{47}{Custom User Interfaces in Gendl\relax }{chapter.8}{}}
\@writefile{toc}{\contentsline {section}{\numberline {8.1}Package and Environment for Web Development}{47}{section.8.1}}
\newlabel{sec:packageandenvironmentforwebdevelopment}{{8.1}{47}{Package and Environment for Web Development\relax }{section.8.1}{}}
\@writefile{toc}{\contentsline {section}{\numberline {8.2}Traditional Web Pages and Applications}{47}{section.8.2}}
......@@ -212,8 +212,8 @@
\newlabel{fig:gwl-1-image}{{8.3}{49}{Simple Static Page Example\relax }{figure.8.3}{}}
\@writefile{lof}{\contentsline {figure}{\numberline {8.4}{\ignorespaces Mixing Static HTML and Dynamic Content}}{50}{figure.8.4}}
\newlabel{fig:gwl-2}{{8.4}{50}{Mixing Static HTML and Dynamic Content\relax }{figure.8.4}{}}
\@writefile{toc}{\contentsline {subsection}{\numberline {8.2.2}A Simple Dynamic Page which Mixes HTML and Common Lisp/GenDL}{50}{subsection.8.2.2}}
\newlabel{subsec:asimpledynamicpagewhichmixeshtmlandcommonlisp/gendl}{{8.2.2}{50}{A Simple Dynamic Page which Mixes HTML and Common Lisp/GenDL\relax }{subsection.8.2.2}{}}
\@writefile{toc}{\contentsline {subsection}{\numberline {8.2.2}A Simple Dynamic Page which Mixes HTML and Common Lisp/Gendl}{50}{subsection.8.2.2}}
\newlabel{subsec:asimpledynamicpagewhichmixeshtmlandcommonlisp/gendl}{{8.2.2}{50}{A Simple Dynamic Page which Mixes HTML and Common Lisp/Gendl\relax }{subsection.8.2.2}{}}
\@writefile{toc}{\contentsline {subsection}{\numberline {8.2.3}Linking to Multiple Pages}{50}{subsection.8.2.3}}
\newlabel{subsec:linkingtomultiplepages}{{8.2.3}{50}{Linking to Multiple Pages\relax }{subsection.8.2.3}{}}
\@writefile{lof}{\contentsline {figure}{\numberline {8.5}{\ignorespaces Mixing Static HTML and Dynamic Content}}{51}{figure.8.5}}
......@@ -222,30 +222,30 @@
\newlabel{subsec:formcontrolsandfillout-forms}{{8.2.4}{51}{Form Controls and Fillout-Forms\relax }{subsection.8.2.4}{}}
\@writefile{toc}{\contentsline {subsubsection}{Form Controls}{51}{section*.9}}
\newlabel{subsubsec:formcontrols}{{8.2.4}{51}{Form Controls\relax }{section*.9}{}}
\@writefile{toc}{\contentsline {subsubsection}{Fillout Forms}{51}{section*.10}}
\newlabel{subsubsec:filloutforms}{{8.2.4}{51}{Fillout Forms\relax }{section*.10}{}}
\@writefile{lof}{\contentsline {figure}{\numberline {8.6}{\ignorespaces Linking to Multiple Pages}}{52}{figure.8.6}}
\newlabel{fig:gwl-3}{{8.6}{52}{Linking to Multiple Pages\relax }{figure.8.6}{}}
\@writefile{lof}{\contentsline {figure}{\numberline {8.7}{\ignorespaces Linking to Multiple Pages}}{52}{figure.8.7}}
\newlabel{fig:gwl-3a}{{8.7}{52}{Linking to Multiple Pages\relax }{figure.8.7}{}}
\@writefile{lof}{\contentsline {figure}{\numberline {8.8}{\ignorespaces Linking to Multiple Pages}}{53}{figure.8.8}}
\newlabel{fig:gwl-3-image}{{8.8}{53}{Linking to Multiple Pages\relax }{figure.8.8}{}}
\@writefile{toc}{\contentsline {section}{\numberline {8.3}Partial Page Updates with gdlAjax}{53}{section.8.3}}
\newlabel{sec:partialpageupdateswithgdlajax}{{8.3}{53}{Partial Page Updates with gdlAjax\relax }{section.8.3}{}}
\@writefile{toc}{\contentsline {subsubsection}{Fillout Forms}{53}{section*.10}}
\newlabel{subsubsec:filloutforms}{{8.2.4}{53}{Fillout Forms\relax }{section*.10}{}}
\@writefile{lof}{\contentsline {figure}{\numberline {8.9}{\ignorespaces Form Controls and Fillout Forms}}{54}{figure.8.9}}
\newlabel{fig:gwl-3b}{{8.9}{54}{Form Controls and Fillout Forms\relax }{figure.8.9}{}}
\@writefile{lof}{\contentsline {figure}{\numberline {8.10}{\ignorespaces Form Controls and Fillout Forms}}{55}{figure.8.10}}
\newlabel{fig:gwl-3b-image}{{8.10}{55}{Form Controls and Fillout Forms\relax }{figure.8.10}{}}
\@writefile{toc}{\contentsline {section}{\numberline {8.3}Partial Page Updates with gdlAjax}{55}{section.8.3}}
\newlabel{sec:partialpageupdateswithgdlajax}{{8.3}{55}{Partial Page Updates with gdlAjax\relax }{section.8.3}{}}
\@writefile{toc}{\contentsline {subsection}{\numberline {8.3.1}Steps to Create a gdlAjax Application}{55}{subsection.8.3.1}}
\newlabel{subsec:stepstocreateagdlajaxapplication}{{8.3.1}{55}{Steps to Create a gdlAjax Application\relax }{subsection.8.3.1}{}}
\@writefile{lof}{\contentsline {figure}{\numberline {8.11}{\ignorespaces Partial Page Updates with GdlAjax}}{56}{figure.8.11}}
\newlabel{fig:gwl-4}{{8.11}{56}{Partial Page Updates with GdlAjax\relax }{figure.8.11}{}}
\@writefile{toc}{\contentsline {subsection}{\numberline {8.3.2}Including Graphics}{57}{subsection.8.3.2}}
\newlabel{subsec:includinggraphics}{{8.3.2}{57}{Including Graphics\relax }{subsection.8.3.2}{}}
\@writefile{lof}{\contentsline {figure}{\numberline {8.12}{\ignorespaces Including Graphics in a Web Page}}{58}{figure.8.12}}
\newlabel{fig:gwl-5}{{8.12}{58}{Including Graphics in a Web Page\relax }{figure.8.12}{}}
\@writefile{lof}{\contentsline {figure}{\numberline {8.13}{\ignorespaces Including Graphics}}{59}{figure.8.13}}
\newlabel{fig:gwl-5-image}{{8.13}{59}{Including Graphics\relax }{figure.8.13}{}}
\@writefile{lof}{\contentsline {figure}{\numberline {8.11}{\ignorespaces Partial Page Updates with GdlAjax}}{57}{figure.8.11}}
\newlabel{fig:gwl-4}{{8.11}{57}{Partial Page Updates with GdlAjax\relax }{figure.8.11}{}}
\@writefile{toc}{\contentsline {subsection}{\numberline {8.3.2}Including Graphics}{58}{subsection.8.3.2}}
\newlabel{subsec:includinggraphics}{{8.3.2}{58}{Including Graphics\relax }{subsection.8.3.2}{}}
\@writefile{lof}{\contentsline {figure}{\numberline {8.12}{\ignorespaces Including Graphics in a Web Page}}{59}{figure.8.12}}
\newlabel{fig:gwl-5}{{8.12}{59}{Including Graphics in a Web Page\relax }{figure.8.12}{}}
\@writefile{lof}{\contentsline {figure}{\numberline {8.13}{\ignorespaces Including Graphics}}{60}{figure.8.13}}
\newlabel{fig:gwl-5-image}{{8.13}{60}{Including Graphics\relax }{figure.8.13}{}}
\@writefile{toc}{\contentsline {chapter}{\numberline {9}More Common Lisp for Gendl}{61}{chapter.9}}
\@writefile{lof}{\addvspace {10\p@ }}
\@writefile{lot}{\addvspace {10\p@ }}
......
......@@ -35,3 +35,5 @@
\indexentry{sequences|hyperpage}{33}
\indexentry{object sequences|hyperpage}{33}
\indexentry{:size|hyperpage}{33}
\indexentry{AJAX|hyperpage}{55}
\indexentry{gdl-ajax-call|hyperpage}{56}
This is makeindex, version 2.15 [TeX Live 2011] (kpathsea + Thai support).
Scanning input file tutorial.idx....done (37 entries accepted, 0 rejected).
Sorting entries....done (208 comparisons).
Generating output file tutorial.ind....done (81 lines written, 0 warnings).
This is makeindex, version 2.15 [TeX Live 2012] (kpathsea + Thai support).
Scanning input file tutorial.idx....done (39 entries accepted, 0 rejected).
Sorting entries....done (211 comparisons).
Generating output file tutorial.ind....done (86 lines written, 0 warnings).
Output written in tutorial.ind.
Transcript written in tutorial.ilg.
......@@ -5,6 +5,10 @@
\indexspace
\item AJAX, \hyperpage{55}
\indexspace
\item Basic Lisp Techniques, \hyperpage{2}
\indexspace
......@@ -29,6 +33,7 @@
\indexspace
\item gdl-ajax-call, \hyperpage{56}
\item gdl-user(1): , \hyperpage{9}
\item Genworks Gendl Console, \hyperpage{7}
......
This diff is collapsed.
......@@ -53,11 +53,11 @@
\BOOKMARK [2][-]{subsection.6.0.2}{View Frames}{subsection.6.0.1}% 53
\BOOKMARK [0][-]{chapter.7}{Working with Geometry in Gendl}{}% 54
\BOOKMARK [1][-]{section.7.1}{The Default Coordinate System in Gendl}{chapter.7}% 55
\BOOKMARK [0][-]{chapter.8}{Custom User Interfaces in GenDL}{}% 56
\BOOKMARK [0][-]{chapter.8}{Custom User Interfaces in Gendl}{}% 56
\BOOKMARK [1][-]{section.8.1}{Package and Environment for Web Development}{chapter.8}% 57
\BOOKMARK [1][-]{section.8.2}{Traditional Web Pages and Applications}{chapter.8}% 58
\BOOKMARK [2][-]{subsection.8.2.1}{A Simple Static Page Example}{section.8.2}% 59
\BOOKMARK [2][-]{subsection.8.2.2}{A Simple Dynamic Page which Mixes HTML and Common Lisp/GenDL}{section.8.2}% 60
\BOOKMARK [2][-]{subsection.8.2.2}{A Simple Dynamic Page which Mixes HTML and Common Lisp/Gendl}{section.8.2}% 60
\BOOKMARK [2][-]{subsection.8.2.3}{Linking to Multiple Pages}{section.8.2}% 61
\BOOKMARK [2][-]{subsection.8.2.4}{Form Controls and Fillout-Forms}{section.8.2}% 62
\BOOKMARK [1][-]{section.8.3}{Partial Page Updates with gdlAjax}{chapter.8}% 63
......
This diff is collapsed.
......@@ -60,17 +60,17 @@
\contentsline {subsection}{\numberline {6.0.2}View Frames}{39}{subsection.6.0.2}
\contentsline {chapter}{\numberline {7}Working with Geometry in Gendl}{43}{chapter.7}
\contentsline {section}{\numberline {7.1}The Default Coordinate System in Gendl}{43}{section.7.1}
\contentsline {chapter}{\numberline {8}Custom User Interfaces in GenDL}{47}{chapter.8}
\contentsline {chapter}{\numberline {8}Custom User Interfaces in Gendl}{47}{chapter.8}
\contentsline {section}{\numberline {8.1}Package and Environment for Web Development}{47}{section.8.1}
\contentsline {section}{\numberline {8.2}Traditional Web Pages and Applications}{47}{section.8.2}
\contentsline {subsection}{\numberline {8.2.1}A Simple Static Page Example}{48}{subsection.8.2.1}
\contentsline {subsection}{\numberline {8.2.2}A Simple Dynamic Page which Mixes HTML and Common Lisp/GenDL}{50}{subsection.8.2.2}
\contentsline {subsection}{\numberline {8.2.2}A Simple Dynamic Page which Mixes HTML and Common Lisp/Gendl}{50}{subsection.8.2.2}
\contentsline {subsection}{\numberline {8.2.3}Linking to Multiple Pages}{50}{subsection.8.2.3}
\contentsline {subsection}{\numberline {8.2.4}Form Controls and Fillout-Forms}{51}{subsection.8.2.4}
\contentsline {subsubsection}{Form Controls}{51}{section*.9}
\contentsline {subsubsection}{Fillout Forms}{51}{section*.10}
\contentsline {section}{\numberline {8.3}Partial Page Updates with gdlAjax}{53}{section.8.3}
\contentsline {subsubsection}{Fillout Forms}{53}{section*.10}
\contentsline {section}{\numberline {8.3}Partial Page Updates with gdlAjax}{55}{section.8.3}
\contentsline {subsection}{\numberline {8.3.1}Steps to Create a gdlAjax Application}{55}{subsection.8.3.1}
\contentsline {subsection}{\numberline {8.3.2}Including Graphics}{57}{subsection.8.3.2}
\contentsline {subsection}{\numberline {8.3.2}Including Graphics}{58}{subsection.8.3.2}
\contentsline {chapter}{\numberline {9}More Common Lisp for Gendl}{61}{chapter.9}
\contentsline {chapter}{\numberline {10}Advanced Gendl}{63}{chapter.10}
......@@ -186,7 +186,7 @@ is this? Please let us know at open-source@genworks.com.
(original-redefinition-warnings
#+allegro excl:*redefinition-warnings*
#+lispworks lw:*redefinition-action*))
(declare (ignore original-redefinition-warnings))
#+(or allegro lispworks) (declare (ignore original-redefinition-warnings))
(defun begin-redefinitions-ok ()
#+sbcl (declare (sb-ext:muffle-conditions sb-ext:compiler-note))
#+(or allegro lispworks)
......
......@@ -265,6 +265,44 @@
(:use :common-lisp :gdl)
,@body))
;;
;; FLAG working on this one to do a proper redefinition.
;;
#+nil
(defmacro gdl:define-package (name &rest body)
(let ((%exports (gensym))
(%uses (gensym))
(%shadowing-import-froms (gensym))
(%shadows (gensym))
(%import-froms (gensym))
(existing-package (gensym)))
`(flet ((,%exports (exports)
(export (mapcar #'(lambda(symbol) (glisp:intern symbol ,name)) exports) ,name))
(,%uses (uses)
(use-package uses ,name))
(,%shadowing-import-froms (imports)
(destructuring-bind (package &rest symbols) imports
(shadowing-import (mapcar #'(lambda(symbol) (glisp:intern symbol package)) symbols)
,name)))
(,%shadows (symbols) (shadow symbols ,name))
(,%import-froms (imports)
(destructuring-bind (package &rest symbols) imports
(import (mapcar #'(lambda(symbol) (glisp:intern symbol package)) symbols) ,name))))
(let ((,existing-package (find-package ,name)))
(if ,existing-package
(progn
(,%exports (rest (find :export ',body :key #'first)))
(,%uses (rest (find :use ',body :key #'first)))
(,%shadowing-import-froms (rest (find :shadowing-import-from ',body :key #'first)))
(,%shadows (rest (find :shadow ',body :key #'first)))
(,%import-froms (rest (find :import-from ',body :key #'first))))
(defpackage ,name
(:shadowing-import-from :gdl #:the) (:use :common-lisp :gdl) ,@body))))))
(gdl:define-package :gdl-user)
......@@ -27,6 +27,18 @@
'gdl-rule:%not-handled%))
(defun input-slots-generics (input-slots)
(let ((input-slot-syms (mapcar #'(lambda(input)
(glisp:intern (if (symbolp (first input))
(first input)
(second input)) :gdl-inputs)) input-slots)))
`(eval-when (:compile-toplevel :load-toplevel :execute)
,@(append
(mapcar #'(lambda(input-sym)
`(unless (fboundp ',input-sym)
(defgeneric ,input-sym (parent object-name self)))) input-slot-syms)))))
(defun input-methods (name attr-sym keys expressions special-keys)
(let ((input (gensym)))
(let ((remove-defunct-expressions
......@@ -62,22 +74,14 @@
(let ((*error-on-not-handled?* t)) ,expr))
`(eval-when (:compile-toplevel :load-toplevel :execute) (glisp:begin-redefinitions-ok))
;;`(defgeneric ,(glisp:intern (symbol-name input-sym) :gdl-slots) (self &rest ,args-arg))
`(eval-when (:compile-toplevel :load-toplevel :execute) (glisp:end-redefinitions-ok))
`(when (or (not (fboundp ',(glisp:intern (symbol-name input-sym) :gdl-slots)))
(not (find-method (symbol-function ',(glisp:intern (symbol-name input-sym) :gdl-slots))
nil (list (find-class 'gdl-basis)) nil)))
(defmethod ,(glisp:intern (symbol-name input-sym) :gdl-slots) ((,self-arg gdl-basis) &rest ,args-arg)
(declare (ignore ,args-arg))
(let ((,parent-arg (the-object ,self-arg %parent%)))
(if (null ,parent-arg) (not-handled ,self-arg ,(make-keyword input-sym))
(,(glisp:intern (symbol-name input-sym) :gdl-inputs)
,parent-arg (the-object ,self-arg :%name%) ,self-arg)))))))))
`(unless (find-method (symbol-function ',(glisp:intern (symbol-name input-sym) :gdl-slots))
nil (list (find-class 'gdl-basis)) nil)
(defmethod ,(glisp:intern (symbol-name input-sym) :gdl-slots) ((,self-arg gdl-basis) &rest ,args-arg)
(declare (ignore ,args-arg))
(let ((,parent-arg (the-object ,self-arg %parent%)))
(if (null ,parent-arg) (not-handled ,self-arg ,(make-keyword input-sym))
(,(glisp:intern (symbol-name input-sym) :gdl-inputs)
,parent-arg (the-object ,self-arg :%name%) ,self-arg)))))))))
keys expressions))))))
......@@ -107,17 +111,14 @@
(the-object ,parent-arg (fetch-input ,(make-keyword attr-sym) ,part-arg ,self-arg))))
`(eval-when (:compile-toplevel :load-toplevel :execute) (glisp:begin-redefinitions-ok))
;;
;; FLAG -- duplicated from objects.lisp
;; FLAG -- duplicated from objects.lisp and from this file --- make a function for this!
;;
;; FLAG -- avoid duplicate invocation of (glisp:intern (symbol-name ...))
;;
;;
`(unless nil #+nil (and (fboundp ',(glisp:intern (symbol-name attr-sym) :gdl-inputs))
(find-method (symbol-function ',(glisp:intern (symbol-name attr-sym) :gdl-inputs))
nil (list (find-class 'gdl-basis) (find-class t) (find-class 'gdl-basis)) nil))
`(unless (find-method (symbol-function ',(glisp:intern (symbol-name attr-sym) :gdl-inputs))
nil (list (find-class 'gdl-basis) (find-class t) (find-class 'gdl-basis)) nil)
(defmethod ,(glisp:intern (symbol-name attr-sym) :gdl-inputs)
((,parent-arg gdl-basis) ,part-arg (,self-arg gdl-basis))
(declare (ignore ,part-arg))
......@@ -127,7 +128,6 @@
(not-handled ,self-arg ,(make-keyword attr-sym)) ,val-arg))))
`(eval-when (:compile-toplevel :load-toplevel :execute) (glisp:end-redefinitions-ok))
`(defmethod ,(glisp:intern (symbol-name attr-sym) :gdl-slots) ((self ,name) &rest ,args-arg)
(declare (ignore ,args-arg))
......@@ -193,14 +193,18 @@
(,self-arg gdl-basis))
(the-object ,parent-arg (fetch-input ,(make-keyword attr-sym) ,part-arg ,self-arg))))
`(defmethod ,(glisp:intern (symbol-name attr-sym) :gdl-inputs) ((,parent-arg gdl-basis)
,part-arg
(,self-arg gdl-basis))
(declare (ignore ,part-arg))
(let ((,val-arg (getf (the-object ,self-arg %parameters%)
,(make-keyword (symbol-name attr-sym)) 'gdl-rule:%not-handled%)))
(if (eql ,val-arg 'gdl-rule:%not-handled%) (not-handled ,parent-arg ,(make-keyword attr-sym)) ,val-arg)))
;;
;; FLAG -- duplicated from objects.lisp and from this file --- make a function for this!
;;
`(unless (find-method (symbol-function ',(glisp:intern (symbol-name attr-sym) :gdl-inputs))
nil (list (find-class 'gdl-basis) (find-class t) (find-class 'gdl-basis)) nil)
(defmethod ,(glisp:intern (symbol-name attr-sym) :gdl-inputs) ((,parent-arg gdl-basis)
,part-arg
(,self-arg gdl-basis))
(declare (ignore ,part-arg))
(let ((,val-arg (getf (the-object ,self-arg %parameters%)
,(make-keyword (symbol-name attr-sym)) 'gdl-rule:%not-handled%)))
(if (eql ,val-arg 'gdl-rule:%not-handled%) (not-handled ,parent-arg ,(make-keyword attr-sym)) ,val-arg))))
`(when (and ,defaulted?
(or (not (fboundp ',(glisp:intern (symbol-name attr-sym) :gdl-trickle-downs)))
......
......@@ -21,6 +21,38 @@
(in-package :gdl)
(defun object-inputs-generics-section (object-specs)
(let* ((special-keys (list :type :sequence :parameters :pass-down :pseudo-inputs))
(object-symbols-in-input-package (remove-duplicates (mapcar #'(lambda(spec) (glisp:intern (if (stringp (first spec))
(second spec) (first spec)) :gdl-inputs))
object-specs)))
(object-input-keys (remove-duplicates
(append
(set-difference (apply #'append (mapcar #'plist-keys (mapcar #'(lambda(spec) (if (stringp (first spec))
(rest (rest spec))
(rest spec)))
object-specs)))
special-keys)
(apply #'append (mapcar #'(lambda(spec) (getf (rest (strip-strings spec)) :pass-down)) object-specs))))))
`(eval-when (:compile-toplevel :load-toplevel :execute)
,@(append
(mapcar #'(lambda(object-symbol)
`(unless (fboundp ',object-symbol)
(defgeneric ,object-symbol (parent object-name self)))) object-symbols-in-input-package)
(mapcar #'(lambda(key)
`(unless (fboundp ',(glisp:intern key :gdl-inputs))
(defgeneric ,(glisp:intern key :gdl-inputs) (parent object-name self)))) object-input-keys)
(mapcar #'(lambda(key)
`(unless (fboundp ',(glisp:intern key :gdl-slots))
(defgeneric ,(glisp:intern key :gdl-slots) (self &rest args)))) object-input-keys)))))
(defun objects-section (name objects)
(let ((special-keys (list :type :sequence :parameters :pass-down :pseudo-inputs)))
(apply
......@@ -196,11 +228,10 @@ item in the list following the :sequence keyword")))))
`(eval-when (:compile-toplevel :load-toplevel :execute) (glisp:begin-redefinitions-ok))
;;
;; FLAG -- duplicated from inputs.lisp
;; FLAG -- duplicated from two places in inputs.lisp --- make a function for this!!
;;
`(unless nil #+nil (and (fboundp ',(glisp:intern (symbol-name attr-sym) :gdl-inputs))
(find-method (symbol-function ',(glisp:intern (symbol-name attr-sym) :gdl-inputs))
nil (list (find-class 'gdl-basis) (find-class t) (find-class 'gdl-basis)) nil))
`(unless (find-method (symbol-function ',(glisp:intern (symbol-name attr-sym) :gdl-inputs))
nil (list (find-class 'gdl-basis) (find-class t) (find-class 'gdl-basis)) nil)
(defmethod ,(glisp:intern (symbol-name attr-sym) :gdl-inputs) ((,parent-arg gdl-basis)
,part-arg
(,self-arg gdl-basis))
......
......@@ -243,7 +243,9 @@ future GDL release."
(class (gensym)))
`(glisp:with-definition-unit
`(progn
;;glisp:with-definition-unit
;;eval-when (:compile-toplevel :load-toplevel)
,(when (and *compile-documentation-database?* documentation)
`(when *load-documentation-database?*
(setf (gdl-documentation ,class) ',documentation)))
......@@ -372,10 +374,6 @@ future GDL release."
quantified-hidden-object-syms trickle-down-slot-syms)))))))
(defmacro defineer-object (&rest args)
`(define-object ,@args))
(defmacro define-object (name mixin-list &rest spec-plist)
"Defines a standard GDL object. Please see the document USAGE.TXT for an
......@@ -400,8 +398,6 @@ overview of <tt>define-object</tt> syntax."
(reserved-word-warning-or-error name messages)
(let ((message-ht (make-hash-table :size (length messages))))
(dolist (message messages)
(push message (gethash message message-ht)))
......@@ -411,7 +407,9 @@ overview of <tt>define-object</tt> syntax."
(when duplicates
(error "duplicate slot name~p: ~{~a~^, ~}" (length duplicates) (sort duplicates #'string-lessp :key #'symbol-name))))))
`(glisp:with-definition-unit
`(progn
;;glisp:with-definition-unit
;;eval-when (:compile-toplevel :load-toplevel)
(defclass ,name ,(if (or no-vanilla-mixin?
(some #'(lambda(mixin)
......@@ -446,14 +444,14 @@ overview of <tt>define-object</tt> syntax."
(let ((method (ignore-errors
(find-method (symbol-function (glisp:intern (symbol-name key) :gdl-slots)) nil
(list ,class-arg) nil))))
(when (and method (not (search "%qb" (string key))))
(when *report-gdl-redefinitions?*
(format t "~%Removing slot: ~a for object definition: ~s~%" key ',name))
(remove-method (symbol-function (glisp:intern (symbol-name key) :gdl-slots)) method)))))
(when method
(when *report-gdl-redefinitions?*
(format t "~%Removing slot: ~a for object definition: ~s~%" key ',name))
(remove-method (symbol-function (glisp:intern (symbol-name key) :gdl-slots)) method)))))
,(when (and *compile-documentation-database?* documentation)
`(when *load-documentation-database?*
(setf (gdl-documentation ,class-arg) ',documentation))))
,(when (and *compile-documentation-database?* documentation)
`(when *load-documentation-database?*
(setf (gdl-documentation ,class-arg) ',documentation))))
(when (message-documentation (find-class ',name)) (clrhash (message-documentation (find-class ',name))))
......@@ -484,6 +482,13 @@ overview of <tt>define-object</tt> syntax."
;; FLAG -- consider pre-cooking these expression lists