diff options
Diffstat (limited to 'Build/source/utils/xindy-new/xindy/src/base.lsp')
-rw-r--r-- | Build/source/utils/xindy-new/xindy/src/base.lsp | 237 |
1 files changed, 0 insertions, 237 deletions
diff --git a/Build/source/utils/xindy-new/xindy/src/base.lsp b/Build/source/utils/xindy-new/xindy/src/base.lsp deleted file mode 100644 index 4158d212f7b..00000000000 --- a/Build/source/utils/xindy-new/xindy/src/base.lsp +++ /dev/null @@ -1,237 +0,0 @@ -;; line 30 "base.nw" -(lisp:defpackage "BASE") -(lisp:in-package "BASE") -(lisp:provide "base") - -#+:CMU17 (defpackage "CLOS") - -(eval-when (compile load eval) - (lisp:use-package "CLOS") - (lisp:use-package "COMMON-LISP") - #+CLISP (lisp:use-package "EXT") - ) - -(eval-when (eval load compile) - #+CLISP (when (find-package "XP") - (pushnew :XP *features*)) - #+(or ALLEGRO :CMU17) (pushnew :XP *features*) - ) - -(setq *print-pretty* t) -(setq *print-escape* t) - -(defparameter *mappings-trace* nil) -(defparameter *locref-trace* nil) -(eval-when (compile load eval) - (export '(*mappings-trace* *locref-trace*))) - -;; line 104 "base.nw" -#-CLISP -(defmacro simple-condition-format-string (&rest args) - `(simple-condition-format-control ,@args)) -#-CLISP -(eval-when (compile load eval) - (export '(simple-condition-format-string))) -;; line 133 "base.nw" -(defmacro info (&rest msg) - `(APPLY #'FORMAT *STANDARD-OUTPUT* (LIST ,@msg))) -;; line 138 "base.nw" -(defparameter *nraw-error-message* "~&WARNING: ") - -(defmacro nraw (&rest msg) - `(PROGN - (FORMAT *ERROR-OUTPUT* BASE::*NRAW-ERROR-MESSAGE*) - (APPLY #'FORMAT *ERROR-OUTPUT* (LIST ,@msg)))) -;; line 147 "base.nw" -(defparameter *oops-error-message* "~&ERROR: ") - -(defmacro oops (&rest msg) - `(LET ((MSG (LIST ,@msg))) - (FORMAT *ERROR-OUTPUT* BASE::*OOPS-ERROR-MESSAGE*) - (APPLY #'FORMAT *ERROR-OUTPUT* MSG) - (WHEN *LOGGING-ON* - (FORMAT *LOGGING-STREAM* BASE::*OOPS-ERROR-MESSAGE*) - (APPLY #'FORMAT *LOGGING-STREAM* MSG)))) -;; line 162 "base.nw" -(defmacro oops* (fmt args) - `(LET ((FMT ,fmt) - (ARGS ,args)) - (FORMAT *ERROR-OUTPUT* BASE::*OOPS-ERROR-MESSAGE*) - (APPLY #'FORMAT *ERROR-OUTPUT* FMT ARGS) - (WHEN *LOGGING-ON* - (FORMAT *LOGGING-STREAM* BASE::*OOPS-ERROR-MESSAGE*) - (APPLY #'FORMAT *LOGGING-STREAM* FMT ARGS)))) -;; line 183 "base.nw" -(defparameter *logging-stream* nil) -(defparameter *logging-on* nil) - -(defmacro gol (flag &rest msg) - `(WHEN (AND ,flag *LOGGING-ON*) - (APPLY #'FORMAT *LOGGING-STREAM* (list ,@msg)))) -;; line 74 "base.nw" -(defmacro ifnot (expr then-body else-body) - `(IF (NOT ,expr) ,then-body ,else-body)) -;; line 82 "base.nw" -(defun error-exit () - #+CLISP (exit 1) - #+ALLEGRO (excl:exit 1) - #+CMU17 (unix:unix-exit 1) - ) - -(defun exit-normally () - #+CLISP (exit 0) - #+ALLEGRO (excl:exit 0) - #+CMU17 (unix:unix-exit 0) - ) -;; line 201 "base.nw" -(defmacro assert! (cond &optional msg) - `(UNLESS ,cond - (FORMAT *ERROR-OUTPUT* "Internal error! Assertion ~A failed!" ',cond) - ,(if msg - `(ERROR "~S" ,msg) - `(ERROR "Entering debugger!")))) - -(pushnew :ASSERT! *features*) -;; line 218 "base.nw" -(defmacro define-slot-accessors (accessors) - `(eval-when (compile load eval) - ,@(apply #'nconc - (mapcar - #'(lambda (acc) - (let ((getnam (intern (concatenate 'string "GET-" - (symbol-name acc)))) - (setnam (intern (concatenate 'string "SET-" - (symbol-name acc)))) - ) - `((defmacro ,getnam (obj) - (list 'slot-value obj '',acc)) - (defmacro ,setnam (val obj) - (list 'setf (list 'slot-value obj '',acc) val)) - (export '(,getnam ,setnam ,acc))))) - accessors)))) - -(define-slot-accessors ( - attribute - base-alphabet - basetype - catattr - catattr-grp-ordnum - entries - entry-list - entry-table - first - group-definition - hierdepth - idxclass - inner - join-length - last - last-in-group - layers - length - letters - locclass - locref-cache - locref-string - locrefs - members - merge-key - sort-key - print-key - main-key - name - order - ordnum - ordnums - origin - processing-ordnum - props - rangeattr - separator - sort-ordnum - state - subentries - subrefs - symbols - target - type - )) -;; line 297 "base.nw" -(defun split-list (split-function list &key sortfunc headfunc) - #+:ASSERT! (assert (not (and sortfunc headfunc)) - () - "split-list") - (let ((list-len (length list))) - (if (= 1 list-len) - (list list) - (let ((split-table (make-hash-table :test #'equal - :size (round (* 1.2 list-len)))) - (key-list '())) - (mapc #'(lambda (elt) - (let ((key (funcall split-function elt))) - (setf (gethash key split-table) - (cons elt (gethash key split-table))))) - list) - (maphash #'(lambda (key element) - (declare (ignore element)) - (push key key-list)) - split-table) - (maplist #'(lambda (rest-list) - (let ((entries (gethash (car rest-list) split-table))) - (if headfunc - (let ((head (find-if headfunc entries))) - (rplaca rest-list - (if head - (cons head (delete head entries)) - entries))) - (rplaca rest-list entries)))) - (if sortfunc (sort key-list sortfunc) key-list)) - key-list)))) - -#| -This version seems to be a little bit slower than the above one, -despite the fact that we use a temporary array with a fill-pointer. - -(defun split-list (split-function sort-function list) - (let ((list-len (length list))) - (if (= 1 list-len) - (list list) - (let ((split-table (make-hash-table :test #'equal - :size (round (* 1.5 list-len))))) - (mapc #'(lambda (elt) - (let ((key (funcall split-function elt))) - (setf (gethash key split-table) - (cons elt (gethash key split-table))))) - list) - (let ((sort-array (make-array (hash-table-count split-table) - :fill-pointer 0))) - (maphash #'(lambda (key element) - (declare (ignore element)) - (vector-push key sort-array)) - split-table) - (map 'list - #'(lambda (key) - (gethash key split-table)) - (sort sort-array sort-function))))))) -|# - -;; line 60 "base.nw" -(defvar *RCS-Identifier* '( -;; line 68 "base.nw" -("base" . "$Id: base.nw,v 1.20 1997/03/26 16:17:58 kehr Exp $") -;; line 60 "base.nw" - )) - -(eval-when (compile load eval) - -;; line 96 "base.nw" -(export '(ifnot error-exit exit-normally)) -;; line 192 "base.nw" -(export '(oops oops* nraw info gol - *logging-stream* *logging-on*)) -;; line 212 "base.nw" -(export 'assert!) -;; line 357 "base.nw" -(export '(split-list)) -;; line 64 "base.nw" - ) |