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