Commit 79b4d6b6 authored by Dave Cooper's avatar Dave Cooper
Browse files

delete obsolete files

parent cfa5a6fe
#!/bin/bash
cd `dirname "$0"`
export os_platform=`uname`
export cl_platform=""
if [ "$1" == "sbcl" ]; then
cl_platform='SBCL'
fi
if [ "$os_platform" == "Linux" ]; then
if [ "$cl_platform" == "" ]; then
cl_platform='Allegro'
fi
emacs --no-splash --no-init-file -l devo.el
elif [ "$os_platform" == "Darwin" ]; then
if [ "$cl_platform" == "" ]; then
cl_platform='LispWorks'
fi
/Applications/Emacs.app/Contents/MacOS/Emacs --no-splash --no-init-file -l devo.el
fi
cd %~dp0
%windir%\system32\cmd.exe "/C start ..\..\common\gpl\gnu-emacs-23.3\bin\runemacs.exe --no-splash --no-init-file -l devo.el"
(require 'cl)
(load (expand-file-name "../../common/quicklisp/slime-helper.el"))
;;
;; FLAG -- learn how to add command line args to inferior-lisp-program
;; to load load.lisp for Genworks GDL automatically.
;;
(setq slime-lisp-implementations
(cond ((and (string= (getenv "cl_platform") "LispWorks")
(string= (getenv "os_platform") "Darwin"))
'((lw60-macosx-x86 ("../../common/lw60-macosx-x86/lw-console"))
(sbcl-1.0.52-x86-64-darwin ("sbcl"))))
((and (string= (getenv "cl_platform") "SBCL")
(string= (getenv "os_platform") "Darwin"))
'((sbcl-1.0.52-x86-64-darwin ("sbcl"))
(lw60-macosx-x86 ("../../common/lw60-macosx-x86/lw-console"))))
((and (string= (getenv "cl_platform") "Allegro")
(string= (getenv "os_platform") "Linux"))
'((acl82m-linux-x86 ("../../common/acl82-linux-x86/mlisp"))
(acl82a-linux-x86 ("../../common/acl82-linux-x86/alisp"))
(sbcl-1.0.50.0.debian ("sbcl"))))
((and (string= (getenv "cl_platform") "SBCL")
(string= (getenv "os_platform") "Linux"))
'((sbcl-1.0.50.0.debian ("sbcl"))
(acl82m-linux-x86 ("../../common/acl82-linux-x86/mlisp"))
(acl82a-linux-x86 ("../../common/acl82-linux-x86/alisp"))))
(t (error (concat "Unknown OS/Lisp combination: "
(getenv "os_platform")
(getenv "cl_platform"))))))
(slime-setup '(slime-fancy))
(defun gdl () (interactive) (slime ))
(setq gdl:*gdl-toplevel* (concat "*" "slime-repl " (symbol-name (first (first slime-lisp-implementations))) "*"))
(setq gdl:*inferior-lisp* "*inferior-lisp*")
(require 'slime-autoloads)
(eval-after-load "slime"
'(progn
(add-to-list 'load-path "/usr/local/slime/contrib")
(slime-setup '(slime-fancy slime-banner))
(setq slime-complete-symbol*-fancy t)
(setq slime-complete-symbol-function 'slime-fuzzy-complete-symbol)))
(global-set-key "\C-x&" '(lambda()(interactive) (switch-to-buffer gdl:*gdl-toplevel*)))
(global-set-key "\C-x*" '(lambda()(interactive) (switch-to-buffer gdl:*inferior-lisp*)))
(global-set-key "\C-xy" '(lambda() (interactive) (other-window -1)))
;;
;; FLAG -- comment the following if you want a tool bar.
;; (errors ignored in case running in a console terminal)
(ignore-errors (tool-bar-mode -1))
(setq visible-bell t)
;;
;; FLAG -- uncomment the following if you don't need a menu bar.
;; (errors ignored in case running in a console terminal)
;;
;;(ignore-errors (menu-bar-mode -1))
;;
;; Use M-x clear-kill-ring in case you have too much garbage in the
;; kill ring
;;
(defun clear-kill-ring () (interactive) (setq kill-ring nil))
;;
;; FLAG -- you can customize default GDL emacs colors here.
;;
(defun gdl:set-colors ()
(interactive)
(progn
(set-foreground-color "white")
(set-background-color "midnight blue")
(setq default-frame-alist (append default-frame-alist '((background-color . "midnight blue"))))
(set-face-foreground 'default "white")
(set-face-foreground 'font-lock-type-face "hotpink")
(set-face-foreground 'font-lock-keyword-face "Cyan")
(set-face-foreground 'font-lock-string-face "#88FFAA")
(set-face-foreground 'font-lock-function-name-face "#55ff88")
(set-face-foreground 'font-lock-comment-face "#888888")
(set-face-foreground 'font-lock-builtin-face "#ffff99")
(add-to-list 'default-frame-alist '(cursor-color . "RosyBrown4"))
(set-cursor-color "#55FFFF")))
;; ignore errors when setting colors in case of running in console
;; terminal (there's probably a better way to test for this).
(ignore-errors (gdl:set-colors))
(defun gdl:set-font ()
(interactive)
(ignore-errors (set-frame-font "-bitstream-Courier 10 Pitch-normal-normal-normal-*-*-*-*-*-m-0-iso10646-1")))
(gdl:set-font)
(show-paren-mode t)
(defun add-gdl-font-lock-keywords ()
(let ((definition-keywords
(regexp-opt (list "define-object-amendment" "define-object" "define-view" "define-lens" "define-format" "define-skin"
"defpart" "defwriter" "defcompanion" "write-the-object" "write-the"
"the " "the-child" "the-object" "the-element" ) t))
(keyword-keywords
(regexp-opt (list ":documentation"
":input-slots" ":computed-slots" ":objects" ":hidden-objects" ":functions" ":methods"
":output-functions" ":skin" ":trickle-down-slots" ":type" ":sequence"
":size" ":parameters" ":pass-down" ":inputs" ":optional-inputs"
":modifiable-optional-inputs" ":descendant-attributes" ":attributes"
":parts" ":pseudo-parts" ":methods") t)))
(pushnew (list definition-keywords 0 font-lock-keyword-face) lisp-font-lock-keywords)
(pushnew (list keyword-keywords 0 font-lock-type-face) lisp-font-lock-keywords)))
(add-gdl-font-lock-keywords)
(defmacro defindent (name indentation)
(let* ((keyword-list '(lisp-font-lock-keywords t t t nil nil nil "&allow-other-keys"))
(spec (if (eq indentation 'gdl-object-style) `((1 t ,keyword-list) (0 t 2)) indentation)))
`(put ',name 'lisp-indent-hook ',spec)))
(defun gdl:define-indents ()
(defindent define-object gdl-object-style)
(defindent define-view (like define-object))
(defindent define-format (like define-object))
(defindent defpart (like define-object))
(defindent defwriter (like define-object))
(defindent defcompanion (like define-object)))
;;
;; From EvW
;;
(setq next-line-add-newlines nil)
(defun ISO-current-time-string ()
(format-time-string "%Y-%m-%dT%T%z"))
(defun EvW-insert-date ()
"time and date function suggested by Tom Capey (2000-11-28T19:21:04+0100)"
(interactive)
(insert (ISO-current-time-string)))
(defun EvW-save-and-kill-buffer (bufname)
"Saves current buffer, then kills it"
(interactive "b")
(let ((cb (current-buffer)))
(save-buffer cb)
(kill-buffer cb)))
(global-set-key "\M-t" 'EvW-insert-date)
(global-set-key "\C-x\C-k" 'EvW-save-and-kill-buffer)
(defvar font-lock-maximum-decoration t)
(global-font-lock-mode t)
(add-hook 'write-file-hooks 'time-stamp)
(defvar time-stamp-active t)
(defvar time-stamp-format "%3a, %:y-%02m-%02dT%02H:%02M:%02S -- %f")
;; if you encounter a file with ^M or ... at the end of every line,
;; this means a worng copy by samba or floppy disk of the DOS file to UNIX.
;; get rid of them by pressing [F5].
(defun cut-ctrlM ()
(interactive)
(goto-char (point-min));(beginning-of-buffer)
(while (search-forward "\r" nil t)
(replace-match "" nil t))
(not-modified)
(goto-char (point-min)))
(defun replace-ctrlM (ch) ;2001-04-17T17:46:41+0200
(interactive)
"Replace all visible ^M with argument (defaulting to the empty string.)"
(goto-char (point-min))
(while (search-forward "\r" nil t)
(replace-match ch nil t))
;;(not-modified)
(goto-char (point-min)))
(defun remove-trailing-whitespace ()
"Removes trailing blanks and tabs from the buffer."
(interactive)
(save-excursion ;let deactivate-mark nil?
(goto-char (point-min))
(while (re-search-forward "[ \t]+$" nil t)
(replace-match "" nil nil))))
(defun tidy-up ()
"Removes trailing whitespace and ^M from the end of lines.
Bug: does not leave point at the position it had when the function was called"
(interactive)
(save-excursion
(let ((curpos (point)))
(cut-ctrlM)
(remove-trailing-whitespace)
(goto-char curpos))))
;;; EOF
(in-package :common-lisp-user)
(load "~/Genworks-GDL/load.lisp")
\ No newline at end of file
(setq next-line-add-newlines nil)
(require 'cl)
;;
;; EvW's prefs
;; To do:
;; - (EvW-save-and-kill-buffer) make argument work sensibly (?)
(defun ISO-current-time-string ()
(format-time-string "%Y-%m-%dT%T%z"))
(defun EvW-insert-date ()
"time and date function suggested by Tom Capey (2000-11-28T19:21:04+0100)"
(interactive)
(insert (ISO-current-time-string)))
;;;open a buffer for logging how my time is spent...
(find-file "~/src/CL/systems/timekeeper/data/uren.csv")
(goto-char (point-max))
(defun EvW-save-and-kill-buffer (bufname)
"Saves current buffer, then kills it"
(interactive "b")
(let ((cb (current-buffer)))
(save-buffer cb)
(kill-buffer cb)))
(defun insert-lisp-file-header (pkg)
"inserts a Lisp header, assuming the file is empty."
(insert ";;; -*- Mode: Lisp -*-")
(insert "\n\n(cl:in-package ")
(let ((pkg-char (point-max))) ;to check package-name later
(insert pkg ")\n\n") ;how to downcase pkg??
(insert ";;; Author: " user-full-name " <" user-mail-address ">\n")
(insert ";;; Created: " (ISO-current-time-string) " as " (buffer-name) "\n")
(insert ";;;Time-stamp: <>\n")
(insert ";;; Purpose:\n")
(insert ";;; To do:\n")
(insert ";;; Remarks:\n\n")
(insert ";;; EOF ")
(goto-char pkg-char)))
(defun find-lisp-file (fpath) ;add a file header when in Lisp-mode
"Finds (Lisp) file indicated and if empty, inserts Lisp comments."
(interactive "FFind (lisp) file: ") ;get file name if called in minibuffer
(let ((pkg ;use a sensible package
(cond ((boundp 'fi:package) fi:package)
((boundp 'fi:default-package) fi:default-package)
((fboundp 'slime-current-package)
(or (slime-current-package) ":cl-user"))
(t ":cl-user")))
(buf (find-file fpath)))
(set-buffer buf)
(when (and (= 0 (buffer-size))
(or (eq major-mode 'lisp-mode)
(eq major-mode 'slime-repl-mode)))
(insert-lisp-file-header pkg))
buf))
(global-set-key "\M-t" 'EvW-insert-date)
(global-set-key "\C-x\C-c" 'EvW-save-and-kill-buffer)
(global-set-key "\C-x\C-f" 'find-lisp-file)
(defvar font-lock-maximum-decoration t)
(global-font-lock-mode t)
(add-hook 'write-file-hooks 'time-stamp)
(defvar time-stamp-active t)
(defvar time-stamp-format "%3a, %:y-%02m-%02dT%02H:%02M:%02S -- %f")
;;; Western European character set (klopt geen reet van)!
;;(add-hook 'text-mode-hook '(lambda () (standard-display-european 1) ))
;;(add-hook 'text-mode-hook '(lambda () (iso-accents-mode 1) ))
(custom-set-faces)
;;; Jim Traugott [traugott@iname.com] -- 2000-02-29T23:42:55
;;; Set the frame's title. %b is the name of the buffer. %+ indicates the
;;; state of the buffer: * if modified, % if read only, or - otherwise. Two
;;; of them to emulate the mode line. %f for the file name.
(setq frame-title-format "Emacs: %b %+%+ %f")
(setq icon-title-format "Emacs - %b")
;;;(require 'eol-conversion) ;remove this for Emacs 21.2?
;;;Playing around with colors
;;;(set-face-foreground 'highlight "black")
(set-face-background 'highlight "green")
;;;(set-face-foreground 'region "black")
(set-face-background 'region "green")
;;;(set-face-foreground 'secondary-selection "antiquewhite1")
(set-face-background 'secondary-selection "Yellow")
(setq-default search-highlight t)
(copy-face 'highlight 'isearch)
(setq-default query-replace-highlight t)
;;;but John ffitch likes these
(custom-set-faces
'(my-tab-face ((((class color)) (:background "lemon chiffon"))) t)
'(my-trailing-space-face ((((class color)) (:background "Gold"))) t))
(defvar font-lock-keywords)
(add-hook 'font-lock-mode-hook
(function
(lambda ()
(setq font-lock-keywords
(append font-lock-keywords
'(("\t+" (0 'my-tab-face t))
("[ \t]+$" (0 'my-trailing-space-face t))))))))
;;;(add-hook 'dired-load-hook
;;; (lambda () (require 'dired-sort-menu)))
;;;highlight during isearch!
;;;(require 'ishl)
;;;(ishl-mode t)
;;;(setq-default ishl-cleanup nil)
;; if you encounter a file with ^M or ... at the end of every line,
;; this means a worng copy by samba or floppy disk of the DOS file to UNIX.
;; get rid of them by pressing [F5].
(defun cut-ctrlM ()
(interactive)
(goto-char (point-min));(beginning-of-buffer)
(while (search-forward "\r" nil t)
(replace-match "" nil t))
(not-modified)
(goto-char (point-min)))
(defun replace-ctrlM (ch) ;2001-04-17T17:46:41+0200
(interactive)
"Replace all visible ^M with argument (defaulting to the empty string.)"
(goto-char (point-min))
(while (search-forward "\r" nil t)
(replace-match ch nil t))
;;(not-modified)
(goto-char (point-min)))
(defun remove-trailing-whitespace ()
"Removes trailing blanks and tabs from the buffer."
(interactive)
(save-excursion ;let deactivate-mark nil?
(goto-char (point-min))
(while (re-search-forward "[ \t]+$" nil t)
(replace-match "" nil nil))))
(defun tidy-up ()
"Removes trailing whitespace and ^M from the end of lines.
Bug: does not leave point at the position it had when the function was called"
(interactive)
(save-excursion
(let ((curpos (point)))
(cut-ctrlM)
(remove-trailing-whitespace)
(goto-char curpos))))
;;; EOF
\ No newline at end of file
;;
;; Copyright 2002-2011 Genworks International and Genworks BV
;;
;; This source file is part of the General-purpose Declarative
;; Language project (GDL).
;;
;; This source file 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 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 :common-lisp-user)
(let ((setup (merge-pathnames "../../common/quicklisp/setup.lisp"
*load-truename*)))
(if (probe-file setup) (load setup)
(progn
(load (merge-pathnames "quicklisp.lisp" *load-truename*))
(funcall (read-from-string "quicklisp-quickstart:install")
:path (make-pathname :name nil
:type nil
:defaults (merge-pathnames "../../common/quicklisp/" *load-truename*))))))
;;
;; FLAG -- Temporary hacks around currently broken Quicklisp .asd files and sytems:
;;
#+allegro
(load (merge-pathnames "quicklisp-local/portableaserve-20110730-cvs/aserve/aserve.asd"
*load-truename*))
(let ((fasl (compile-file
(merge-pathnames
"quicklisp-local/cl-typesetting-20110219-svn/hyphenation-fp.lisp"
*load-truename*))))
(load fasl)
(delete-file fasl))
;;
;; FLAG -- figure out how to get all these loaded automatically
;; or placed/linked in a standard location.
;;
(load (merge-pathnames "gdl/base/gdl-base.asd" *load-truename*))
(load (merge-pathnames "gdl/cl-lite/gdl-cl-lite.asd" *load-truename*))
(load (merge-pathnames "gdl/geom-base/gdl-geom-base.asd" *load-truename*))
(load (merge-pathnames "gdl/gwl/gdl-gwl.asd" *load-truename*))
(load (merge-pathnames "gdl/gwl-graphics/gdl-gwl-graphics.asd" *load-truename*))
(load (merge-pathnames "gdl/apps/tree/gdl-tree.asd" *load-truename*))
(load (merge-pathnames "gdl/apps/ta2/gdl-ta2.asd" *load-truename*))
(load (merge-pathnames "gdl/apps/tasty/gdl-tasty.asd" *load-truename*))
(load (merge-pathnames "demos/gdl-demos.asd" *load-truename*))
(load (merge-pathnames "build/gdl-build.asd" *load-truename*))
(load (merge-pathnames "gdl/apps/yadd/gdl-yadd.asd" *load-truename*))
(load (merge-pathnames "gdl-all.asd" *load-truename*))
(ql:quickload :gdl-all)
;;
;; FLAG -- following two and other specific feature additions should be done by .asd system
;; "perform" statements (when I figure out how those work).
;;
(pushnew :genworks-base *features*)
(pushnew :genworks-gdl-base *features*)
(pushnew :genworks-cl-lite *features*)
;;
;; Skeleton "vanilla" geometry kernel - nonfunctional without SMLib module.
;;
(load (merge-pathnames "surf/gdl-surf.asd" *load-truename*))
;;;; -*- mode: lisp -*-
;;;;
;;;; This as an ASDF system for ASERVE meant to replace
;;;; aserve-cmu.system, but could replace all other systems, too.
;;;; (hint, hint)
(defpackage #:aserve-system
(:use #:cl #:asdf))
(in-package #:aserve-system)
(defclass acl-file (cl-source-file) ())
(defmethod asdf:source-file-type ((c acl-file) (s module)) "cl")
;;;; ignore warnings
;;;;
;;;; FIXME: should better fix warnings instead of ignoring them
;;;; FIXME: (perform legacy-cl-sourcefile) duplicates ASDF code
(defclass legacy-acl-source-file (acl-file)
()
(:documentation
"Common Lisp source code module with (non-style) warnings.
In contrast to CL-SOURCE-FILE, this class does not think that such warnings
indicate failure."))
(defmethod perform ((operation compile-op) (c legacy-acl-source-file))
(let ((source-file (component-pathname c))
(output-file (car (output-files operation c)))
(warnings-p nil)
(failure-p nil))
(setf (asdf::component-property c 'last-compiled) nil)
(handler-bind ((warning (lambda (c)
(declare (ignore c))
(setq warnings-p t)))
;; _not_ (or error (and warning (not style-warning)))
(error (lambda (c)
(declare (ignore c))
(setq failure-p t))))
(compile-file source-file
:output-file output-file))
;; rest of this method is as for CL-SOURCE-FILE
(setf (asdf::component-property c 'last-compiled) (file-write-date output-file))
(when warnings-p
(case (asdf::operation-on-warnings operation)
(:warn (warn "COMPILE-FILE warned while performing ~A on ~A"
c operation))
(:error (error 'compile-warned :component c :operation operation))
(:ignore nil)))
(when failure-p
(case (asdf::operation-on-failure operation)
(:warn (warn "COMPILE-FILE failed while performing ~A on ~A"
c operation))
(:error (error 'compile-failed :component c :operation operation))
(:ignore nil)))))
#+(or lispworks cmu sbcl mcl openmcl clisp)
(defsystem aserve
:name "AllegroServe (portable)"
:author "John K. Foderaro"
:version "1.2.35"
:licence "LLGPL"
:default-component-class acl-file
:components ((:file "packages")
(:file "macs" :depends-on ("packages"))
(:legacy-acl-source-file "main" :depends-on ("macs"))
(:file "headers" :depends-on ("main"))
(:legacy-acl-source-file "parse" :depends-on ("main"))
(:file "decode" :depends-on ("main"))
(:file "publish" :depends-on ("main"))
(:file "authorize" :depends-on ("main" "publish"))
(:file "log" :depends-on ("main"))
(:file "client" :depends-on ("main"))
(:file "proxy" :depends-on ("main" "headers")))
:depends-on (htmlgen acl-compat)
:perform (load-op :after (op aserve)
(pushnew :aserve cl:*features*)))
#+allegro
(defclass original-aserve (asdf:component)
((loaded :initform nil :accessor loaded)))
;;
;; DJC
;;
#+allegro
(defmethod asdf:source-file-type ((c original-aserve) (s module)) "dummy")
;;
;; /DJC
;;
#+allegro
(defmethod asdf:perform ((op asdf:load-op) (c original-aserve))
#+common-lisp-controller (c-l-c:original-require 'aserve)
#-common-lisp-controller (require 'aserve)
(setf (loaded c) t))
#+allegro
(defmethod asdf:operation-done-p ((op asdf:load-op) (c original-aserve))
(loaded c))
#+allegro
(defmethod asdf:operation-done-p ((op asdf:compile-op) (c original-aserve))
t)
#+allegro
(defsystem aserve
:components ((:original-aserve "dummy")))
;;; Logical pathname is needed by AllegroServe examples
#+(or lispworks cmu mcl openmcl clisp sbcl)
(setf (logical-pathname-translations "ASERVE")
`(
#+ignore ; Don't need this with asdf
("**;*.lisp.*" ;,(logical-pathname "**;*.cl.*")
,(merge-pathnames
(make-pathname :host (pathname-host *load-truename*)
:directory '(:relative "aserve"
:wild-inferiors)
:name :wild
:type "cl"
:version :wild)
*load-truename*
))
("**;*.*.*"