diff options
Diffstat (limited to 'Build/source/utils/xindy-old/src/base.lsp')
| -rw-r--r-- | Build/source/utils/xindy-old/src/base.lsp | 237 |
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" + ) |