summaryrefslogtreecommitdiff
path: root/Build/source/utils/xindy/xindy-src/src/base.lsp
diff options
context:
space:
mode:
Diffstat (limited to 'Build/source/utils/xindy/xindy-src/src/base.lsp')
-rw-r--r--Build/source/utils/xindy/xindy-src/src/base.lsp237
1 files changed, 0 insertions, 237 deletions
diff --git a/Build/source/utils/xindy/xindy-src/src/base.lsp b/Build/source/utils/xindy/xindy-src/src/base.lsp
deleted file mode 100644
index 4158d212f7b..00000000000
--- a/Build/source/utils/xindy/xindy-src/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"
- )