Commit d0fd4d99 authored by Dave Cooper's avatar Dave Cooper

did release 1585p002

parent 3a83fe5a
......@@ -4,7 +4,7 @@
"The Gendl™ (legacy) Testing and Tracking Utility, version 2 (using Ajax but pre-gdlAjax, and no JQuery or CSS)"
:author "Dave Cooper and Genworks International" :license
"Gnu Affero General Public License (please see http://www.gnu.org/licenses/)"
:serial t :version "20140122" :depends-on (:gwl-graphics)
:serial t :version "20140204" :depends-on (:gwl-graphics)
#-asdf-unicode :defsystem-depends-on #-asdf-unicode (:asdf-encodings)
#+asdf-encodings :encoding #+asdf-encodings :utf-8
:components
......
......@@ -4,7 +4,7 @@
"The Gendl™ Web-based Development Environment (tasty)" :author
"Dave Cooper and Genworks International" :license
"Gnu Affero General Public License (please see http://www.gnu.org/licenses/)"
:serial t :version "20140122" :depends-on (:tree :gwl-graphics)
:serial t :version "20140204" :depends-on (:tree :gwl-graphics)
#-asdf-unicode :defsystem-depends-on #-asdf-unicode (:asdf-encodings)
#+asdf-encodings :encoding #+asdf-encodings :utf-8
:components
......
......@@ -4,7 +4,7 @@
"The Gendl™ Translators to/from XML and potentially other high-level KBE and Knowledge formats"
:author "Dave Cooper and Genworks International" :license
"Gnu Affero General Public License (please see http://www.gnu.org/licenses/)"
:serial t :version "20140122" :depends-on (:gwl)
:serial t :version "20140204" :depends-on (:gwl)
#-asdf-unicode :defsystem-depends-on #-asdf-unicode (:asdf-encodings)
#+asdf-encodings :encoding #+asdf-encodings :utf-8
:components
......
......@@ -4,7 +4,7 @@
"The Gendl™ Tree component used by Tasty and potentially as a UI component on its own"
:author "Dave Cooper and Genworks International" :license
"Gnu Affero General Public License (please see http://www.gnu.org/licenses/)"
:serial t :version "20140122" :depends-on (:gwl-graphics)
:serial t :version "20140204" :depends-on (:gwl-graphics)
#-asdf-unicode :defsystem-depends-on #-asdf-unicode (:asdf-encodings)
#+asdf-encodings :encoding #+asdf-encodings :utf-8
:components
......
......@@ -4,7 +4,7 @@
"The Gendl™ Yet Another Definition Documenter (yadd)" :author
"Dave Cooper and Genworks International" :license
"Gnu Affero General Public License (please see http://www.gnu.org/licenses/)"
:serial t :version "20140122" :depends-on
:serial t :version "20140204" :depends-on
(:gwl-graphics #-allegro :cl-html-parse)
#-asdf-unicode :defsystem-depends-on #-asdf-unicode (:asdf-encodings)
#+asdf-encodings :encoding #+asdf-encodings :utf-8
......
......@@ -4,7 +4,7 @@
"The Gendl™ Base Core Kernel Engine" :author
"Dave Cooper and Genworks International" :license
"Gnu Affero General Public License (please see http://www.gnu.org/licenses/)"
:serial t :version "20140122" :depends-on nil
:serial t :version "20140204" :depends-on nil
#-asdf-unicode :defsystem-depends-on #-asdf-unicode (:asdf-encodings)
#+asdf-encodings :encoding #+asdf-encodings :utf-8
:components
......
......@@ -4,7 +4,7 @@
"The Gendl™ Compile-and-Load Lite Utility" :author
"Dave Cooper and Genworks International" :license
"Gnu Affero General Public License (please see http://www.gnu.org/licenses/)"
:serial t :version "20140122" :depends-on (:glisp)
:serial t :version "20140204" :depends-on (:glisp)
#-asdf-unicode :defsystem-depends-on #-asdf-unicode (:asdf-encodings)
#+asdf-encodings :encoding #+asdf-encodings :utf-8
:components
......
......@@ -4,8 +4,7 @@
"The Gendl™ Wireframe School Bus Demo" :author
"Dave Cooper and Genworks International" :license
"Gnu Affero General Public License (please see http://www.gnu.org/licenses/)"
:serial t :version "20140122" :depends-on
(#-gwl-graphics :gwl-graphics)
:serial t :version "20140204" :depends-on nil
#-asdf-unicode :defsystem-depends-on #-asdf-unicode (:asdf-encodings)
#+asdf-encodings :encoding #+asdf-encodings :utf-8
:components
......
"(#-gwl-graphics :gwl-graphics)"
\ No newline at end of file
nil
\ No newline at end of file
......@@ -4,7 +4,7 @@
"The Gendl™ Ledger Bookkeeping Demo" :author
"Dave Cooper and Genworks International" :license
"Gnu Affero General Public License (please see http://www.gnu.org/licenses/)"
:serial t :version "20140122" :depends-on
:serial t :version "20140204" :depends-on
(#-gwl :gwl)
#-asdf-unicode :defsystem-depends-on #-asdf-unicode (:asdf-encodings)
#+asdf-encodings :encoding #+asdf-encodings :utf-8
......
"(#-gendl :gwl-graphics)"
\ No newline at end of file
nil
\ No newline at end of file
......@@ -4,8 +4,7 @@
"The Gendl™ Simplified Android Robot example " :author
"Dave Cooper and Genworks International" :license
"Gnu Affero General Public License (please see http://www.gnu.org/licenses/)"
:serial t :version "20140122" :depends-on
(#-gendl :gwl-graphics)
:serial t :version "20140204" :depends-on nil
#-asdf-unicode :defsystem-depends-on #-asdf-unicode (:asdf-encodings)
#+asdf-encodings :encoding #+asdf-encodings :utf-8
:components
......
......@@ -4,7 +4,7 @@
"The Gendl™ Wire-World demo and test-case for wireframe tessellation and X3D output"
:author "Dave Cooper and Genworks International" :license
"Gnu Affero General Public License (please see http://www.gnu.org/licenses/)"
:serial t :version "20140122" :depends-on
:serial t :version "20140204" :depends-on
(#-gwl-graphics :gwl-graphics)
#-asdf-unicode :defsystem-depends-on #-asdf-unicode (:asdf-encodings)
#+asdf-encodings :encoding #+asdf-encodings :utf-8
......
......@@ -4,7 +4,7 @@
"The Gendl™ examples Subsystem" :author
"Dave Cooper and Genworks International" :license
"Gnu Affero General Public License (please see http://www.gnu.org/licenses/)"
:serial t :version "20140122" :depends-on (:gwl-graphics :surf)
:serial t :version "20140204" :depends-on (:gwl-graphics :surf)
#-asdf-unicode :defsystem-depends-on #-asdf-unicode (:asdf-encodings)
#+asdf-encodings :encoding #+asdf-encodings :utf-8
:components
......
......@@ -15,6 +15,8 @@
(require 'cl)
(defvar *default-font-size* 15)
(defun maximize-frame ()
"Maximizes the active frame in Windows"
(interactive)
......@@ -90,16 +92,13 @@
;;(global-set-key (kbd "C-m") 'newline-and-indent)
)
(gdl:global-keys)
;; 3.5. Font
(defun gdl:set-font ()
(interactive)
(let ((font-size (1+ (/ (display-pixel-height) 100))))
(let ((font-size *default-font-size*)) ;; (/ (display-mm-height) 16)
(set-frame-font
(format
(case system-type
......@@ -126,19 +125,24 @@
;;
;; 4.1. Some synonyms
(defun gendl () (interactive)
(defun gendl (&optional exe) (interactive)
(add-hook 'slime-connected-hook 'load-and-or-start-gendl t)
;;(add-hook 'slime-connected-hook 'load-base-ql)
(add-to-list 'auto-mode-alist '("\\.cl\\'" . lisp-mode))
(add-to-list 'auto-mode-alist '("\\.gdl\\'" . lisp-mode))
(add-to-list 'auto-mode-alist '("\\.gendl\\'" . lisp-mode))
(with-temp-buffer (cd *gendl-home*) (slime)))
(defun gdl () (interactive) (gendl))
(with-temp-buffer (cd *gendl-home*) (slime exe)))
(defun gdl () (interactive) (gendl 'gdl))
(defun agdl8 () (interactive) (gendl 'agdl8))
(defun glime () (interactive) (gendl))
(defun gdl-quit () (interactive) (slime-quit-lisp))
(defun gq () (interactive) (gdl-quit))
(defun gendl-quit () (interactive) (gdl-quit))
(defun quit-gendl () (interactive) (gdl-quit))
(defun quit-gdl () (interactive) (gdl-quit))
;; 4.2. Locate Common Lisp / Locate SLIME
......@@ -191,26 +195,37 @@
(slime-repl-return))
(defvar gdl-startup-string
(format
"(progn (unless (find-package :gendl)
(let ((load-file (or (probe-file (merge-pathnames \".load-gendl.lisp\" (user-homedir-pathname)))
(probe-file \"c:/users/dcooper8/.load-gendl.lisp\"))))
(load load-file)))
(when (and (find-package :gendl) (find-package :swank))
(load (compile-file \"%semacs/glime.lisp\"
:output-file
(merge-pathnames
(make-pathname :name \"glime\"
:type (symbol-value
(read-from-string \"glisp:*fasl-extension*\")))
(funcall (symbol-function (read-from-string \"glisp:temporary-folder\")))))))
(when (find-package :gendl) (funcall (symbol-function (read-from-string \"gendl::startup-banner\"))))
(let ((gendl-loaded? (find-package :gendl)) (genworks-gdl-loaded? (find-package :genworks-gdl)))
(cond (genworks-gdl-loaded? (funcall (symbol-function (read-from-string \"gdl:start-gdl!\"))))
(gendl-loaded? (funcall (symbol-function (read-from-string \"gendl:start-gendl!\"))))
(t (format t \"~%%~%%***~%%Gendl or GDL is not loaded and did not load successfully from .load-gendl.lisp in your home directory.~%%***~%%~%%\"))))
(when (find-package :gendl) (in-package :gdl-user)))" *gendl-home*))
(defun load-and-or-start-gendl ()
(slime-repl)
(insert "(unless (find-package :gendl)
(let ((load-file (or (probe-file (merge-pathnames \".load-gendl.lisp\" (user-homedir-pathname)))
(probe-file \"c:/users/dcooper8/.load-gendl.lisp\"))))
(load load-file)))")
(slime-repl-return)
(insert (format "(when (find-package :gendl) (load (compile-file \"%semacs/glime.lisp\")))" *gendl-home*))
(slime-repl-return)
(insert "(when (find-package :gendl) (funcall (symbol-function (read-from-string \"gendl::startup-banner\"))))")
(slime-repl-return)
(insert "(let ((gendl-loaded? (find-package :gendl)) (genworks-gdl-loaded? (find-package :genworks-gdl)))
(cond (genworks-gdl-loaded? (funcall (symbol-function (read-from-string \"gdl:start-gdl!\"))))
(gendl-loaded? (funcall (symbol-function (read-from-string \"gendl:start-gendl!\"))))
(t (format t \"~%~%***~%Gendl or GDL is not loaded and did not load successfully from .load-gendl.lisp in your home directory.~%***~%~%\"))))")
(slime-repl-return)
(insert "(when (find-package :gendl) (in-package :gdl-user))")
(insert gdl-startup-string)
(slime-repl-return)
(end-of-buffer))
(defun set-slime-shortcuts ()
"Set keybindings for switching to slime buffers"
(interactive)
......@@ -263,7 +278,59 @@
;; 5. MAKE IT HAPPEN
(prior-to-glime)
(glime)
;;
;; FLAG -- conditionalize based on running slime or ELI
;;
;;(glime)
(defvar *eli-init* (concat *gendl-home* "program/eli/fi-site-init.el"))
(when (file-exists-p *eli-init*)
(defun get-executable (exe-name)
(let* ((info (assoc exe-name slime-lisp-implementations )))
(replace-regexp-in-string
"/program/program/" "/program/"
(case system-type
(windows-nt
(concat (file-name-directory (first (second info)))
(replace-regexp-in-string "\\\\" "/" (second (second info)))))
((darwin gnu/linux)
(first (second info)))))))
(defvar gdl:*gdl-toplevel-base* "*gdl toplevel*")
(defun agdl8e () (interactive)
(gdl-devo (get-executable 'agdl8)))
(defun gdle () (interactive)
(gdl-devo (get-executable 'gdl)))
(defun gdl-devo (executable)
(interactive)
(load-file *eli-init*)
(setq gdl:*gdl-toplevel*
(concat gdl:*gdl-toplevel-base*
(if (equalp (subseq (file-name-sans-extension (file-name-nondirectory executable))
0 1) "a")
"(ANSI)" "(modern)")))
(fi:common-lisp gdl:*gdl-toplevel* *gendl-home* executable nil)
(global-set-key "\C-x&" '(lambda()(interactive) (switch-to-buffer gdl:*gdl-toplevel*)))
(switch-to-buffer gdl:*gdl-toplevel*)
(end-of-buffer)
(goto-char (point-max))
(insert gdl-startup-string)
(fi:inferior-lisp-newline)
(end-of-buffer)))
......
......@@ -4,7 +4,7 @@
"The Gendl™ Wireframe Geometry" :author
"Dave Cooper and Genworks International" :license
"Gnu Affero General Public License (please see http://www.gnu.org/licenses/)"
:serial t :version "20140122" :depends-on (:glisp)
:serial t :version "20140204" :depends-on (:glisp)
#-asdf-unicode :defsystem-depends-on #-asdf-unicode (:asdf-encodings)
#+asdf-encodings :encoding #+asdf-encodings :utf-8
:components
......
......@@ -4,7 +4,7 @@
"The Gendl™ Common Lisp Portability" :author
"Dave Cooper and Genworks International" :license
"Gnu Affero General Public License (please see http://www.gnu.org/licenses/)"
:serial t :version "20140122" :depends-on
:serial t :version "20140204" :depends-on
(:base :uiop :cl-typesetting :cl-ppcre :cl-who #-allegro :cl-base64 #-allegro :babel #-allegro :acl-compat)
#-asdf-unicode :defsystem-depends-on #-asdf-unicode (:asdf-encodings)
#+asdf-encodings :encoding #+asdf-encodings :utf-8
......
......@@ -672,7 +672,8 @@ please find implementation for the currently running lisp.~%")
(append
(mapcar #'(lambda(option) (concatenate 'string "--" option)) long-form-options)
(list (expanded-pathname-string (namestring source)))
(list (expanded-pathname-string (namestring dest)))))))))
(list (if (search ":" (namestring dest)) dest
(expanded-pathname-string (namestring dest))))))))))
(when (or print-command? dry-run?) (format t "~s~%" command-list))
(unless dry-run?
(uiop:with-current-directory (directory)
......
......@@ -4,7 +4,7 @@
"The Gendl™ GWL embedded graphics support" :author
"Dave Cooper and Genworks International" :license
"Gnu Affero General Public License (please see http://www.gnu.org/licenses/)"
:serial t :version "20140122" :depends-on (:geom-base :gwl)
:serial t :version "20140204" :depends-on (:geom-base :gwl)
#-asdf-unicode :defsystem-depends-on #-asdf-unicode (:asdf-encodings)
#+asdf-encodings :encoding #+asdf-encodings :utf-8
:components
......
......@@ -4,7 +4,7 @@
"The Gendl™ Generative Web Language (GWL)" :author
"Dave Cooper and Genworks International" :license
"Gnu Affero General Public License (please see http://www.gnu.org/licenses/)"
:serial t :version "20140122" :depends-on (:glisp :aserve)
:serial t :version "20140204" :depends-on (:glisp :aserve)
#-asdf-unicode :defsystem-depends-on #-asdf-unicode (:asdf-encodings)
#+asdf-encodings :encoding #+asdf-encodings :utf-8
:components
......
# This makefile requires GNU make.
include version.mak
ifeq ($(emacs),xemacs)
xemacs = yes
endif
SHELL = sh
###############################################################################
# $(OS) is from the environment on Windows NT
ifeq ($(OS),Windows_NT)
ifdef xemacs
#### non-Cygwin can't do -nw
#xemacsdir := $(shell perl xemacsdir.pl)
#emacs = $(xemacsdir)/XEmacs-21.1.9/i386-pc-win32/xemacs.exe
#### Cygwin version is just right
#emacs = /usr/bin/i686-pc-cygwin32/xemacs
emacs = /usr/bin/xemacs
pwd = $(shell pwd)
else
emacsdir := $(shell perl emacsdir.pl)
emacs = $(emacsdir)/bin/emacs.exe
# ../bin/pwd prints like c:/... instead of /c/... like the cygnus version.
pwd = $(shell ../bin/pwd.exe)
endif
###############################################################################
else ### unix
ifdef xemacs
emacs = xemacs
else
emacs = emacs
endif
pwd = $(shell pwd)
endif
###############################################################################
ifeq ($(OS),Windows_NT)
ifdef xemacs
pwd = $(shell pwd)
else
pwd = $(shell ../bin/pwd)
endif
endif
ifndef xemacs
test_rule = test.out
endif
all default: fi-vers.el compile $(test_rule)
compile: fi-vers.el
"$(emacs)" -batch -q -l $(pwd)/fi-compile.el -kill
fi-vers.el: Makefile version.mak
# rm -f fi-vers.el
echo ';; automatically generate file--do not edit.' > fi-vers.el
echo '(defvar fi:emacs-lisp-interface-version)' >> fi-vers.el
echo '(setq fi:emacs-lisp-interface-version "$(VERSION)")' >> fi-vers.el
echo '(defvar fi::compiled-with-version)' >> fi-vers.el
echo '(setq fi::compiled-with-version (eval-when-compile (cons emacs-major-version emacs-minor-version)))' >> fi-vers.el
ifeq ($(OS),Windows_NT)
unix2dos fi-vers.el
endif
#readme.htm: readme0.htm
# sed -e 's/__VERSION__/$(VERSION)/g' < readme0.htm > readme.htm
test.out: $(elcs) fi-test.el
"$(emacs)" -nw -batch -q -l fi-test.el
@date > test.out
clean: FORCE
rm -f *.elc *.doc readme*.htm test.out
tags: FORCE
etags *.el
FORCE:
include local.mak
;; A sample ~/.emacs file.
;;
;; $Id: emacs.el,v 3.0 2003/12/15 22:52:58 layer Exp $
(defvar *eli-directory*)
(setq *eli-directory* (expand-file-name "~/cl-ultra/src/eli/"))
(when (and (not (string-match "xemacs" emacs-version))
(= emacs-major-version 20)
(<= emacs-minor-version 2))
(setq load-path (cons *eli-directory* load-path)))
(load (format "%sfi-site-init" *eli-directory*))
(setq fi:common-lisp-image-name "/usr/local/cl-5.0")
(setq fi:common-lisp-host "ultra")
;; This function starts up lisp with your defaults.
(defun run-common-lisp ()
(interactive)
(fi:common-lisp fi:common-lisp-buffer-name
fi:common-lisp-directory
fi:common-lisp-image-name
fi:common-lisp-image-arguments
fi:common-lisp-host
fi:common-lisp-image-file))
;; Set up a keybinding for `run-common-lisp', two possible ways:
(progn
(setq ctlx-3-map (make-keymap))
(define-key ctl-x-map "3" ctlx-3-map)
(define-key ctlx-3-map "l" 'run-common-lisp))
;; or this:
(define-key global-map "\C-xl" 'run-common-lisp)
;; Run cl each time emacs is run:
(run-common-lisp)
;; Date: Wed, 13 Aug 2003 11:29:42 -0600
;; From: "Clementson, Bill"
;;
;; I frequently use the following function in place of the special-purpose
;; eval-compile functions. You might want to consider something similar for
;; inclusion in ELI (it could be bound to "C-c C-d"):
;; $Id: eval.el,v 3.0 2003/12/15 22:52:58 layer Exp $
(defun fi:lisp-eval-or-compile-dwim (compilep)
"Send the appropriate forms to the Lisp subprocess associated with
this buffer (Do What I Mean). If a region is selected, evaluate the
region. If the cursor is on or immediately after a ')', evaluate the
last sexp. If the cursor is on or immediately before a '(', evaluate
the next sexp. If the cursor is inside a defun, evaluate the defun. If
the cursor is inside a top-level sexp, evaluate the top-level
sexp. Tests are done in the order specified in these comments, so if
there is any ambiguity, make certain that the cursor is either on a
parenthesis (for the eval last/next commands or not directly
before/after/on a parenthesis for the eval defun/top-level commands.
See the documentation for fi:lisp-evals-always-compile."
(interactive (fi::decode-prefix-argument-for-eval-or-compile))
(save-excursion
(cond
;;Region selected - evaluate region
((not (equal mark-active nil))
(fi:lisp-eval-or-compile-region compilep))
;; At/after sexp - evaluate last sexp
((or (looking-at "\\s\)")
(save-excursion
(backward-char 1)
(looking-at "\\s\)")))
(if (looking-at "\\s\)")
(forward-char 1))
(fi:lisp-eval-or-compile-last-sexp compilep))
;; At/before sexp - evaluate next sexp
((or (looking-at "\\s\(")
(save-excursion
(forward-char 1)
(looking-at "\\s\(")))
(if (looking-at "\\s\(")
(forward-list 1))
(fi:lisp-eval-or-compile-last-sexp compilep))
;; Default - evaluate enclosing defun/sexp
(t (fi:lisp-eval-or-compile-defun compilep)))))
This diff is collapsed.
;; This file can be loaded at emacs build time to have the emacs-lisp
;; interface preloaded into the image.
(setq fi::build-time t)
(load "fi-site-init")
;; Copyright (c) 1987-2002 Franz Inc, Berkeley, Ca.
;;
;; Permission is granted to any individual or institution to use, copy,
;; modify, and distribute this software, and to distribute modified
;; versions, provided that this complete copyright and permission notice is
;; maintained, intact, in all copies and supporting documentation.
;;
;; Franz Incorporated provides this software "as is" without
;; express or implied warranty.
;; Support for changed definitions
(defvar fi:change-definitions-since-default
'last-compile-or-eval
"*The value of this variable is used as the default SINCE
argument to the changed-definition commands. The value must be one of the
symbols file-first-read, buffer-save or last-compile-or-eval, which
correspond to SINCE arguments of 1, 2 and 3. The meaning of each of the
values are:
file-first-read - the changes since the file was first read by emacs are
used,
buffer-save - the changes since the last buffer save are used, and
last-compile-or-eval - the changes since the last compile or eval changed
definition command was issued.")
(defun fi::change-definition-convert-prefix-argument ()
(list
(if (null current-prefix-arg)
fi:change-definitions-since-default
(cond ((eq 1 current-prefix-arg) 'file-first-read)
((eq 2 current-prefix-arg) 'buffer-save)
((eq 3 current-prefix-arg) 'last-compile-or-eval)
((eq 4 current-prefix-arg) 'comma-zero)
(t (error "prefix argument should be between 1 and 4"))))))
(defun fi:list-buffer-changed-definitions (since)
"List the definitions in the current buffer which have been added,
deleted or changed. See the documentation for the variable
fi:change-definitions-since-default for information on the behavior of
SINCE."
(interactive (fi::change-definition-convert-prefix-argument))
(fi::do-buffer-changed-definitions ':list since))
(defun fi:list-changed-definitions (since)
"List the definitions in all buffers which have been added,
deleted or changed. See the documentation for the variable
fi:change-definitions-since-default for information on the behavior of
SINCE."
(interactive (fi::change-definition-convert-prefix-argument))
(fi::do-buffer-changed-definitions ':list since t))
(defun fi:eval-buffer-changed-definitions (since)
"Eval the definitions in the current buffer which have been added or
changed. See the documentation for the variable
fi:change-definitions-since-default for information on the behavior of
SINCE."
(interactive (fi::change-definition-convert-prefix-argument))
(fi::do-buffer-changed-definitions ':eval since))
(defun fi:eval-changed-definitions (since)
"Eval the definitions in all buffers which have been added or
changed. See the documentation for the variable
fi:change-definitions-since-default for information on the behavior of
SINCE."
(interactive (fi::change-definition-convert-prefix-argument))
(fi::do-buffer-changed-definitions ':eval since t))
(defun fi:compile-buffer-changed-definitions (since)
"Compile the definitions in the current buffer which have been added or
changed. See the documentation for the variable
fi:change-definitions-since-default for information on the behavior of
SINCE."
(interactive (fi::change-definition-convert-prefix-argument))
(fi::do-buffer-changed-definitions ':compile since))
(defun fi:compile-changed-definitions (since)
"Compile the definitions in all buffers which have been added or
changed. See the documentation for the variable
fi:change-definitions-since-default for information on the behavior of
SINCE."
(interactive (fi::change-definition-convert-prefix-argument))
(fi::do-buffer-changed-definitions ':compile since t))
(defun fi:copy-buffer-changed-definitions (since)
"Copy into the kill ring the definitions in the current buffer which have
been added or changed. See the documentation for the variable
fi:change-definitions-since-default for information on the behavior of
SINCE."
(interactive (fi::change-definition-convert-prefix-argument))
(fi::do-buffer-changed-definitions ':copy since))
(defun fi:copy-changed-definitions (since)
"Copy into the kill ring the definitions in all buffers which have been
added or changed. See the documentation for the variable
fi:change-definitions-since-default for information on the behavior of
SINCE."
(interactive (fi::change-definition-convert-prefix-argument))
(fi::do-buffer-changed-definitions ':copy since t))
(defun fi:compare-source-files (new-file old-file)
"Compare two files, NEW-FILE and OLD-FILE, listing the definitions in the
in NEW-FILE which have been added, deleted or changed with respect to
OLD-FILE."
(interactive "fNew file: \nfOld file: ")
(find-file new-file)
(let ((actual-file (buffer-file-name (find-buffer-visiting new-file)))
(xpackage (fi::package)))
(fi::make-request (scm::list-changed-definitions
:transaction-directory fi:emacs-to-lisp-transaction-directory
:operation ':list
:actual-file actual-file
:old-file old-file
:new-file new-file)
((xpackage) (changes)
(if changes
(fi::show-changes changes nil xpackage)
(message "There are no changes.")))
(() (error)
(error "Cannnot list changed definitions: %s" error)))))
;;; The guts of the problem
(defun fi::do-buffer-changed-definitions (operation since
&optional all-buffers)
(message "Computing changes...")
(let ((copy-file-name (and (eq operation ':copy)
(format "%s/%s.cl"
fi:emacs-to-lisp-transaction-directory
(make-temp-name "EtoL")))))
(if all-buffers
(let ((args nil))
(save-excursion
(dolist (buffer (buffer-list))
(set-buffer buffer)
(if (fi::check-buffer-for-changes-p since)
(push (fi::compute-file-changed-values-for-current-buffer
since)
args))))
(if args
(apply (function fi::do-buffer-changed-definitions-1)
operation since
copy-file-name
(fi::transpose-list args))
(message "There are no changes.")))
(if (fi::check-buffer-for-changes-p since)
(apply (function fi::do-buffer-changed-definitions-1)
operation since
copy-file-name
(fi::compute-file-changed-values-for-current-buffer since))
(message "There are no changes.")))))
(defvar fi::unlock-file-suffix ",0")
(defun fi::check-buffer-for-changes-p (since)
"Decide whether this buffer is worth checking for changes."
(and (eq major-mode 'fi:common-lisp-mode)
(buffer-file-name)
(ecase since
(comma-zero
(file-exists-p (concat (buffer-file-name) fi::unlock-file-suffix)))
(file-first-read (or (buffer-modified-p) buffer-backed-up))
(buffer-save (buffer-modified-p))
(last-compile-or-eval
;; Its like this buffer needs an every-modified-flag
t))))
(defun fi::compute-file-changed-values-for-current-buffer (since)
(let ((actual-file (buffer-file-name))
(old-file
(case since
(comma-zero (concat (buffer-file-name) fi::unlock-file-suffix))
(t (if (and (not (eq since 'buffer-save))
buffer-backed-up)
(car (fi::find-most-recent-backup-file-name
(buffer-file-name)))
(buffer-file-name))))))
(list actual-file old-file actual-file)))
(defun fi::do-buffer-changed-definitions-1 (operation since
copy-file-name actual-file
old-file new-file)
(fi::make-request (scm::list-changed-definitions
:operation operation
:copy-file-name copy-file-name
:actual-file actual-file
:old-file old-file