;; line 289 "idxstyle.nw" ;; $Id: idxstyle.nw,v 1.19 1997/03/26 16:18:23 kehr Exp $ ;; (lisp:defpackage "IDXSTYLE") (lisp:in-package "IDXSTYLE") (lisp:provide "idxstyle") #+CLISP (lisp:require "base") #+CLISP (lisp:require "locref") (eval-when (compile load eval) (lisp:use-package "CLOS") (lisp:use-package "COMMON-LISP") #+CLISP (lisp:use-package "EXT") #+(and :XP CLISP) (lisp:use-package "XP") #-CLISP (lisp:require "base") #-CLISP (lisp:require "locref") (lisp:use-package "BASE") (lisp:use-package "LOCREF") ;; line 472 "intface.nw" (eval-when (eval load compile) (when (find-package "ORDRULES") (pushnew :ORDRULES *features*))) ;; line 306 "idxstyle.nw" ;; see submodule intface ) ;; line 78 "idxstyle.nw" (defparameter *indexstyle* nil) (defparameter *indexstyle-readtable* (copy-readtable)) (defparameter *included-files* '()) (defvar *load-paths* "") (defparameter *default-load-paths* *load-paths*) (defparameter *default-minimum-range-length* 2) (defparameter *default-locref-hierdepth* 0) ;; line 1151 "intface.nw" ;; $Id: intface.nw,v 1.30 1997/10/20 11:25:09 kehr Exp $ ;; line 1016 "intface.nw" ;;; $Id: intface.nw,v 1.30 1997/10/20 11:25:09 kehr Exp $ ;;;---------------------------------------------------------------------- ;;; ;;; util-lib LISP Utitlity Library ;;; ;;; (history at end) ;(provide 'util-lib) ;(in-package 'util-lib) (defvar whole) (eval-when (compile load eval) (export '(destructuring-switch-bind &switch whole))) (defmacro destructuring-switch-bind (lambdalist expr . body) "Similar to 'destructuring-bind' but also allows switch options at the end of LAMBDALIST with the following syntax: &switch { var | (var key [defval]) | (var ({ key }*) [defval]) }* In all cases VAR will be accessible in BODY as a variable. If only VAR is specified, it is bound to the keyword with the same name, if that keyword occured in EXPR. Otherwise it is bound to NIL. If both a VAR and KEY were specified, VAR will be bound to KEY, if KEY occured in EXPR and to NIL otherwise. If VAR and a list of KEYs were specified, VAR will be bound to the first KEY, which occured in EXPR. If none of the KEYS occured within EXPR, VAR will be bound to NIL. If DEFVAL was specified, variable will be bound to DEFVAL instead of NIL in cases where no switch keyword was found in EXPR. " (let* ((switchlist (member '&switch lambdalist)) ;; 'remove' switches from lambdalist (lambdalist (ldiff lambdalist switchlist)) ;; drop &switch keyword (switches (when switchlist (cdr switchlist))) ;; construct bindings for each switch and collect valid ;; keywords in 'switchkeys' (switchkeys '()) (bindings (mapcar #'(lambda (spec) (cond ;; spec simply consists of VAR ((symbolp spec) (let ((key (intern (symbol-name spec) 'keyword))) (push key switchkeys) `(,spec (FIND ,key )) )) ;; spec is (VAR form) ((and (listp spec) (>= (list-length spec) 2)) (let ((var (first spec)) (keyspec (second spec)) (defval (when (cddr spec) (third spec)))) (cond ;; spec is (VAR (KEY1 KEY2 ...)) ((listp keyspec) `(,var (COND ,@(mapcar #'(lambda (key) (push key switchkeys) `((FIND ,key ) ,key)) keyspec) (T ,defval)))) ;; spec is (VAR KEY) (t (push keyspec switchkeys) ` (,var (OR (FIND ,keyspec ) ,defval))) ))) ;; illegal spec (t (error "~A is not a valid switch specifier." spec)) )) switches)) ) ;; construct the expansion form ` (LET (( ,expr)) (LET ,bindings (HANDLER-CASE (DESTRUCTURING-BIND ,lambdalist (SET-DIFFERENCE-KEEP-ORIGINAL-ORDER ',switchkeys) ,@body) (ERROR (COND) (DECLARE (IGNORE COND)) (ERROR "~&Syntax Error in ~S." WHOLE) ) ) ) ) )) (defun set-difference-keep-original-order (set1 set2) (mapcan #'(lambda (elt) (unless (member elt set2) (list elt))) set1)) #| (destructuring-switch-bind (name &rest args &key foo bar &switch on ; simple form (started :start) (speed (:fast :slow)) (off :turn-off :turn-on) ; with switch key (choose (:one :two :three) :three)) '(width :foo 5 :bar 7 :on :turn-off :one) (list name foo bar args on started speed off choose)) |# ;; line 111 "intface.nw" (eval-when (compile load eval) (defun stringify (name) (declare (inline)) (etypecase name (symbol (symbol-name name)) (string name) (number (write-to-string name))))) (defun list-of-strings-p (x) (cond ((not (listp x)) nil) ((every #'(lambda (elt) (or (stringp elt) (symbolp elt) (numberp elt))) x)))) ;; line 136 "intface.nw" (defun make-well-formed-list (attr-list) (mapcar #'(lambda (x) (cond ((null x) (error "empty lists are not allowed !")) ((or (symbolp x) (stringp x) (numberp x)) (list (stringify x))) ((listp x) (map-to-strings x)))) attr-list)) (defun map-to-strings (slist) (mapcar #'(lambda (x) (cond ((null x) (error "empty lists are not allowed !")) ((or (symbolp x) (stringp x) (numberp x)) (stringify x)) ((listp x) (error "nesting level too deep !")) (t (error "~S is not a string !" x)))) slist)) ;; line 185 "intface.nw" (defun c-string-reader (stream char) (declare (ignore char)) (let ((ch nil) (str (make-array 32 :element-type #+CLISP 'string-char #-CLISP 'base-char :adjustable t :fill-pointer 0))) (loop (setq ch (read-char stream t #\Newline t)) (case ch (#\" (let ((nextch (read-char-no-hang stream t #\Newline t))) (when nextch (unread-char nextch stream) (case nextch (#\Newline) (#\t) (#\Space) (#\)) (t (nraw "~&Possible read-error due to ill-formed string \"~A\" ~S" str *)))) (return str))) (#\~ (setq ch (read-char stream t #\Newline t)) (case ch (#\n (vector-push-extend #\Newline str)) (#\t (vector-push-extend #\Tab str)) (#\b (vector-push-extend (character 1) str)) (#\e (vector-push-extend (character 255) str)) (t (vector-push-extend ch str)))) (t (vector-push-extend ch str)))))) (set-macro-character #\" #'c-string-reader nil *indexstyle-readtable*) #| (let ((x #\Null)) (loop for i from 1 to 255 do (progn (print (character i)) (when (char>= x (character i)) (print "Whee!")) (setq x (character i))))) |# ;; line 254 "intface.nw" (defmacro define-alphabet (&whole whole &optional name string-list) (cond ;; line 239 "intface.nw" ((null name) (error "missing argument in `~S' !" whole)) ((not (or (symbolp name) (stringp name))) (error "~S is not a symbol or a string in `~S' !" name whole)) ;; line 256 "intface.nw" ((not (listp string-list)) (error "missing argument !")) ((not (list-of-strings-p string-list)) (error "~S is not a list of strings" string-list)) (t `(LET ((NAME (STRINGIFY ',name))) (WHEN (LOOKUP-BASETYPE *indexstyle* NAME) (NRAW "redefining alphabet `~S'" NAME)) (ADD *indexstyle* (MAKE-ALPHABET NAME ',string-list)))))) (defmacro define-alphabet* (&whole whole &optional name string-list) (cond ;; line 239 "intface.nw" ((null name) (error "missing argument in `~S' !" whole)) ((not (or (symbolp name) (stringp name))) (error "~S is not a symbol or a string in `~S' !" name whole)) ;; line 267 "intface.nw" ((not (listp string-list)) (error "missing argument !")) (t (let ((scar (car string-list))) (if (and (symbolp scar) (fboundp scar)) `(LET ((NAME (STRINGIFY ',name)) (STRING-LIST ,string-list)) #| evaluates string-list |# (UNLESS (LIST-OF-STRINGS-P STRING-LIST) (ERROR "~S is not a list of strings" STRING-LIST)) (WHEN (LOOKUP-BASETYPE *indexstyle* NAME) (NRAW "redefining alphabet `~S'" NAME)) (ADD *indexstyle* (MAKE-ALPHABET NAME STRING-LIST)))))))) ;; line 284 "intface.nw" (defmacro define-enumeration (&whole whole &optional name prefix-match-func base-alphabet) (cond ;; line 239 "intface.nw" ((null name) (error "missing argument in `~S' !" whole)) ((not (or (symbolp name) (stringp name))) (error "~S is not a symbol or a string in `~S' !" name whole)) ;; line 289 "intface.nw" ((null prefix-match-func) (error "missing argument !")) (t (let* ((name (stringify name)) (symbol (make-symbol (concatenate 'string "ENUMERATION-" name)))) `(LET () #| PROGN instead of LET () yields a runtime error !? |# (IF (LOOKUP-BASETYPE *indexstyle* ,name) (NRAW "redefining alphabet `~S'" ,name) (PROGN (DEFCLASS ,symbol (ENUMERATION) ()) (ADD *indexstyle* (MAKE-ENUMERATION ',symbol ,name ,base-alphabet)))) (DEFMETHOD PREFIX-MATCH ((STR STRING) (ENUM ,symbol)) (FUNCALL ,prefix-match-func STR))))))) ;; line 312 "intface.nw" (defmacro define-location-class (&whole whole &rest args) (destructuring-switch-bind (name layer-list &key (min-range-length *default-minimum-range-length*) (hierdepth 0) ;no hierarchies are to be formed &switch (var :var)) args (cond ((null name) (error "missing argument in~%~S" whole)) ((null layer-list) (error "missing argument in~%~S" whole)) ;;((not (list-of-strings-p layer-list)) ;; (error "~S is not a list of strings in~%~S" layer-list whole)) ((not (numberp hierdepth)) (error "~S is not a number! in~%~S" hierdepth whole)) ((not (or (numberp min-range-length) (eql 'none min-range-length))) (error "~S must be a number or the keyword `none' in~%~S" min-range-length whole)) (t (when (eql 'none min-range-length) (setq min-range-length 0)) `(LET ((NAME (STRINGIFY ',name)) (LAYERS (BUILD-LOCCLASS-LAYERS ',layer-list ',whole))) ;;(GOL T "~&define-location-class: ~S" LAYERS) (COND ((LOOKUP-CROSSREF-CLASS *indexstyle* NAME) (OOPS "replacing cross-reference-class `~S' is not allowed !" NAME)) (t (WHEN (LOOKUP-LOCATION-CLASS *indexstyle* NAME) (NRAW "redefining location-reference-class `~S' !" NAME)) (ADD *indexstyle* ,(if var `(CHECKED-MAKE-VAR-LOCATION-CLASS NAME LAYERS ,hierdepth) `(CHECKED-MAKE-STANDARD-LOCATION-CLASS NAME LAYERS ,min-range-length ,hierdepth)))) )))))) ;; line 354 "intface.nw" (defun build-locclass-layers (layers whole) (let ((res-list '())) (loop ;;(gol t "~&build-locclass-layers: ~S" layers) (when (endp layers) (return (nreverse res-list))) (cond ((eql :sep (car layers)) (setq layers (cdr layers)) (if (endp layers) (error "Reached end of list in~%~S" whole) (push (make-loccls-separator (stringify (car layers))) res-list))) (t (let* ((layer (stringify (car layers))) (basetype (lookup-basetype *indexstyle* layer))) (if basetype (push (make-loccls-layer basetype) res-list) (error "Unknown basetype ~S in~%~S" layer whole))))) (setq layers (cdr layers))))) ;; line 377 "intface.nw" (defmacro define-crossref-class (&whole whole &rest args) (destructuring-switch-bind (name &switch (verified :unverified)) args (cond ;; line 239 "intface.nw" ((null name) (error "missing argument in `~S' !" whole)) ((not (or (symbolp name) (stringp name))) (error "~S is not a symbol or a string in `~S' !" name whole)) ;; line 382 "intface.nw" (t `(LET ((NAME (STRINGIFY ',name))) (cond ((LOOKUP-LOCATION-CLASS *indexstyle* NAME) (OOPS "replacing location-reference-class `~S' is not allowed !" NAME)) (t (WHEN (LOOKUP-CROSSREF-CLASS *indexstyle* NAME) (NRAW "redefining crossref-location-class `~S'" NAME)) (ADD *indexstyle* ,(if verified `(MAKE-UNVERIFIED-CROSSREF-LOCATION-CLASS NAME) `(MAKE-VERIFIED-CROSSREF-LOCATION-CLASS NAME)))))))))) ;; line 398 "intface.nw" (defmacro define-location-class-order (olist) (cond ((not (listp olist)) (error "missing argument !")) ((not (list-of-strings-p olist)) (error "~S is not a list of strings" olist)) (t `(LET ((CTR 1)) (MAPC #'(LAMBDA (NAME) (LET* ((NEW-NAME (STRINGIFY NAME)) (LOCCLS (CDR (LOOKUP-LOCATION-CLASS *indexstyle* NEW-NAME)))) (INCF CTR) (COND (LOCCLS (SET-ORDNUM CTR LOCCLS)) (t (OOPS "unknown location-class `~S'" NEW-NAME))))) ',olist))))) ;; line 423 "intface.nw" (defmacro define-attributes (&whole whole &optional attr-list) (cond ((null attr-list) (error "missing argument in~&~S" whole)) (t (let* ((wf-attr-list (make-well-formed-list attr-list)) (plain-list (apply #'concatenate 'list wf-attr-list)) ) `(PROGN (MAPCAR #'(LAMBDA (CATATTR) (IF (LOOKUP-CATATTR *indexstyle* CATATTR) (NRAW "ignoring redefinition of attribute ~S in~&~S" CATATTR ',whole) (ADD *indexstyle* (MAKE-CATEGORY-ATTRIBUTE CATATTR)))) ',plain-list) (INITIALIZE-CATEGORY-ATTRIBUTES ',wf-attr-list *indexstyle*)) )))) ;; line 488 "intface.nw" #+:ORDRULES (defmacro merge-rule (&whole whole &rest args) (destructuring-switch-bind (pattern replacement &switch (again :again) (string :string) (extended-regexp :eregexp) (basic-regexp :bregexp)) args (cond ((null pattern) (error "missing argument !")) ((or (and string extended-regexp) (and string basic-regexp) (and extended-regexp basic-regexp)) (error "~&Only one of (:string :bregexp :eregexp) allowed in:~&~S !" whole)) ((null replacement) (error "~&Missing argument in:~&~S!" whole)) (t `(PROGN (UNLESS (ZEROP (ORDRULES:ADD-KEYWORD-MERGE-RULE ,pattern ,replacement ,(if again 1 0) ,(cond (string 1) (basic-regexp 2) (extended-regexp 3) (t 0)))) (OOPS "~&Wrong regular expression ~S in:~%~S." ',pattern ',whole)) (FLUSH-ORDRULES-MESSAGE-BUFFER)))))) #-:ORDRULES (defmacro merge-rule (&rest args) (declare (ignore args)) (oops "merge-rule not supported! ignoring definition")) ;; line 525 "intface.nw" #+:ORDRULES (defparameter *sort-rule-orientations* '(forward forward forward forward forward forward forward forward)) #+:ORDRULES (defmacro define-sort-rule-orientations (&whole whole &rest args) (destructuring-switch-bind (&optional (orientations *sort-rule-orientations*)) args (unless (every #'(lambda (run) (member run '(forward backward))) orientations) (error "~&Elements of ~S must be one of {forward,backward}!" orientations)) `(PROGN (SETQ *SORT-RULE-ORIENTATIONS* ',orientations) (ORDRULES:INITIALIZE (LENGTH *SORT-RULE-ORIENTATIONS*)) (FLUSH-ORDRULES-MESSAGE-BUFFER)))) #+:ORDRULES (defmacro define-rule-set (&whole whole &rest args) (destructuring-bind (&optional name &key inherit-from rules) args (cond ;; line 239 "intface.nw" ((null name) (error "missing argument in `~S' !" whole)) ((not (or (symbolp name) (stringp name))) (error "~S is not a symbol or a string in `~S' !" name whole)) ;; line 554 "intface.nw" ((not (listp rules)) (error "missing argument !")) (t `(LET ((RS (MAKE-RULE-SET ',name ',inherit-from ',rules))) (MAPC #'(LAMBDA (INH-NAME) (INHERIT-RULE-SET RS (LOOKUP-RULE-SET *INDEXSTYLE* INH-NAME))) ',inherit-from) (ADD-RULE-SET *INDEXSTYLE* RS)))))) #-:ORDRULES (defmacro define-rule-set (&rest args) (declare (ignore args)) (oops "define-rule-sets not supported! ignoring definition")) #+:ORDRULES (defmacro use-rule-set (&whole whole &rest args) ;; FIXME: if we use destructuring-switch-bind-here an error occurs (destructuring-bind (&key run rule-set) args (cond ((not (integerp run)) (error "incorrect argument !")) ((not rule-set) (error "missing argument !")) ((not (or (listp rule-set) (stringp rule-set))) (error "wrong argument to !")) (t `(INSTANTIATE-RULE-SET ,run ,rule-set))))) #-:ORDRULES (defmacro use-rule-set (&rest args) (declare (ignore args)) (oops "use-rule-sets not supported! ignoring definition")) #+:ORDRULES (defmacro sort-rule (&whole whole &rest args) (destructuring-switch-bind (pattern replacement &key (run 0) &switch (again :again) (string :string) (extended-regexp :eregexp) (basic-regexp :bregexp)) args (cond ((null pattern) (error "missing argument !")) ((or (< run 0) (>= run (length *sort-rule-orientations*))) (error "~&Argument of :run must be in the interval [0..~A]!" (length *sort-rule-orientations*))) ((or (and string extended-regexp) (and string basic-regexp) (and extended-regexp basic-regexp)) (error "~&Only one of (:string :bregexp :eregexp) allowed in:~&~S !" whole)) ((null replacement) (error "missing argument !")) (t `(PROGN (UNLESS (ZEROP (ORDRULES:ADD-KEYWORD-SORT-RULE ,run ,pattern ,replacement ,(if again 1 0) ,(cond (string 1) (basic-regexp 2) (extended-regexp 3) (t 0)))) (OOPS "~&Wrong regular expression ~S in:~%~S." ',pattern ',whole)) (FLUSH-ORDRULES-MESSAGE-BUFFER)))))) #-:ORDRULES (defmacro define-sort-rule-orientations (&rest args) (declare (ignore args)) (oops "define-sort-rule-orientations not supported! ignoring definition")) #-:ORDRULES (defmacro sort-rule (&rest args) (declare (ignore args)) (oops "sort-rule not supported! ignoring definition")) (defun flush-ordrules-message-buffer () #+:ORDRULES (when (and *mappings-trace* ordrules::*message-logging*) (gol t "~A" ordrules::*message-buffer*) (setq ordrules::*message-buffer-ptr* 0))) ;; line 696 "intface.nw" (defmacro define-letter-group (&whole whole name &key prefixes before after) (cond ;; line 239 "intface.nw" ((null name) (error "missing argument in `~S' !" whole)) ((not (or (symbolp name) (stringp name))) (error "~S is not a symbol or a string in `~S' !" name whole)) ;; line 699 "intface.nw" ((and before (not (lookup-letter-group-definition *indexstyle* before))) (error "~S does not name a letter group in~%~S" before whole)) ((and after (not (lookup-letter-group-definition *indexstyle* after))) (error "~S does not name a letter group in~%~S" after whole)) ((not (list-of-strings-p prefixes)) (error "argument is not a list of strings in~%~S" whole)) (t `(LET () (ADD-LETTER-GROUPS *INDEXSTYLE* ,name ',(or prefixes (list name)) :BEFORE ,before :AFTER ,after))))) ;; line 718 "intface.nw" (defmacro define-letter-groups (&whole whole &optional letter-groups) (cond ((not (list-of-strings-p letter-groups)) (error "~S is not a list of strings in~%~S" letter-groups whole)) (t `(LET () (ADD-LETTER-GROUPS *INDEXSTYLE* ,(car letter-groups) ',(list (car letter-groups))) ,@(let ((last (car letter-groups))) (mapcar #'(lambda (letter-group) (prog1 `(ADD-LETTER-GROUPS *INDEXSTYLE* ,letter-group ',(list letter-group) :AFTER ,last) (setq last letter-group))) (cdr letter-groups))))))) ;; line 650 "intface.nw" (defmacro merge-to (&whole whole &rest args) (destructuring-switch-bind (from to &switch drop) args (let ((from-attr (lookup-catattr *indexstyle* from)) (to-attr (lookup-catattr *indexstyle* to))) (cond ((not from-attr) (nraw "`~S' is not a known attribute in:~&~A" from whole)) ((not to-attr) (nraw "`~S' is not a known attribute in:~&~A" to whole)) (t (if drop `(ADD-DROP-IF-MERGED-RULE *INDEXSTYLE* ',from-attr ',to-attr) `(ADD-MERGE-RULE *INDEXSTYLE* ',from-attr ',to-attr))))))) ;; line 740 "intface.nw" ;;; we remove the inherited symbol and establish a new one (eval-when (compile load eval) (shadow 'require)) (defmacro require (&rest args) (cond ((null args) (error "missing argument !")) ((not (stringp (car args))) (error "(require ~S): expected !" (car args))) (t `(LET ((FILENAME (STRINGIFY ',(car args)))) (DO-REQUIRE FILENAME))))) (defun do-require (filename) (let ((file (find-file filename))) (unless (member file *included-files* :test #'equalp) (push file *included-files*) (info "~&Loading module ~S..." filename) (watched-load file :echo t) (info "~&Finished loading module ~S.~%" filename)))) #| (defun do-require (filename) (let ((file (find-file filename))) (unless (member file *included-files* :test #'equalp) (push file *included-files*) (info "~&Loading module ~S..." filename) (let ((*standard-output* (make-string-output-stream))) (handler-case (load file :verbose nil :echo t) ; (stream-error (cond) ; (step ; (progn ; (oops* ; (simple-condition-format-string cond) ; (simple-condition-format-arguments cond)) ; (exit)) ; ) ; ) (error (condition) (info "~&~%~A~%" ";;;;;;;;;;;;;;;;;;;;;;;;") (info "~A~%" ";; ERROR SECTION START") (info "~%~A~%" (get-output-stream-string *standard-output*)) (info "~%~A~%" ";; ERROR SECTION END") (info "~A~%~%" ";;;;;;;;;;;;;;;;;;;;;;;;") (oops* (simple-condition-format-string condition) (simple-condition-format-arguments condition)) (error-exit)) ) ) (info "~&Finished loading module ~S.~%" filename)))) |# ;; line 802 "intface.nw" (defun find-file (filename) (let ((file (parse-namestring filename))) (when (equal (file-namestring file) "") (error "~S is not a valid filename !" filename)) (let ((found (some #'(lambda (path) (and (probe-file (append-pathnames path file)))) *load-paths*))) (or found (error "Could not find file ~S !" filename))))) ;; line 813 "intface.nw" (defvar *wl-fmt* "~&~%Error in line ~S:~%~A~%") (defun watched-load (filename &key (print *load-print*) (if-does-not-exist t) echo) (let ((stream (open (setq filename (pathname filename)) :direction #+CLISP :input-immutable #-CLISP :input :element-type #+CLISP 'string-char #-CLISP 'base-char :if-does-not-exist nil)) (lineno 1)) (if stream (let* ((load-stream (make-string-output-stream)) (input-stream (if echo (make-echo-stream stream load-stream) stream )) (*load-pathname* (if (pathnamep filename) filename nil)) (*load-truename* (if (pathnamep filename) (truename filename) nil)) (*package* *package*) ; *PACKAGE* binden (*readtable* *readtable*) ; *READTABLE* binden (end-of-file "EOF")) ; einmaliges Objekt ;;(setq sys::*load-input-stream* input-stream) (block nil (unwind-protect (tagbody weiter (let* ((obj (handler-case (read input-stream nil end-of-file) (error (cond) (when echo (let* ((str (get-output-stream-string load-stream)) (cnt (count #\Newline str))) (info *wl-fmt* (+ cnt lineno) str) (oops* (simple-condition-format-string cond) (simple-condition-format-arguments cond)) (error-exit)))))) (str (get-output-stream-string load-stream)) (cnt (count #\Newline str))) (incf lineno cnt) (when (eql obj end-of-file) (return-from nil)) (setq obj (multiple-value-list (cond ((compiled-function-p obj) (funcall obj)) ;;(compiling (funcall (compile-form obj nil nil nil nil nil))) (t (handler-case (eval obj) (error (cond) (info *wl-fmt* lineno str) (oops* (simple-condition-format-string cond) (simple-condition-format-arguments cond)) (error-exit))) (get-output-stream-string load-stream) )))) (when print (when obj (print (first obj)))) ) (go weiter) ) (close stream) (close input-stream) ) ) t) (if if-does-not-exist (error "A file with name ~A does not exist" filename) nil) ) )) ;; line 891 "intface.nw" (defmacro searchpath (&rest args) (cond ((null args) (error "missing argument !")) ((stringp (car args)) `(SET-SEARCHPATH-BY-STRING ,(car args))) ((listp args) `(SET-SEARCHPATH ',(car args))))) (defun set-searchpath-by-string (searchpath-str) (set-searchpath (string-to-searchlist searchpath-str))) ;; line 913 "intface.nw" (defun string-to-searchlist (str) (let ((paths '()) pos) (nreverse (loop (when (equalp str "") (return (push :default paths))) (setq pos (position #+UNIX #\: #+OS/2 #\; str)) (if pos (progn (push (subseq str 0 pos) paths) (setq str (subseq str (1+ pos)))) (return (push str paths))))))) (defun set-searchpath (path-list) (setq *load-paths* (apply #'nconc (mapcar #'(lambda (elt) (cond ((stringp elt) (list (make-real-pathname elt))) ((eq elt :default) *default-load-paths*) ((eq elt :last) *load-paths*) (t (oops "~&searchpath: invalid argument ~S in~%~S" elt path-list)))) path-list)))) ;; line 954 "intface.nw" #+CLISP (defun make-real-pathname (pathname-str) (let* ((pn (pathname pathname-str)) (fname (file-namestring pn))) (if (string/= fname "") (make-pathname :device (pathname-device pn) :directory (append (or (pathname-directory pn) '(:relative)) (list fname))) pn))) ;; line 966 "intface.nw" #-CLISP (defun make-real-pathname (pathname-str) (let ((pn (parse-namestring (if (eql (elt pathname-str (1- (length pathname-str))) #\/) pathname-str (concatenate 'string pathname-str "/"))))) (if (pathname-directory pn) pn (make-pathname :directory (list :relative (pathname-name pn)))))) ;; line 986 "intface.nw" (defun append-pathnames (pn-dir pn-sub) (let ((dir-dir (pathname-directory pn-dir)) (dir-sub (pathname-directory pn-sub))) (cond ((eq :absolute (car dir-sub)) pn-sub) (t (make-pathname :device (pathname-device pn-dir) :directory (append dir-dir (cdr dir-sub)) :name (pathname-name pn-sub) :type (pathname-type pn-sub)))))) ;; line 62 "intface.nw" (defparameter *idxstyle-user-interface-definitions* '( *default-minimum-range-length* *included-files* *indexstyle-readtable* define-alphabet define-alphabet* define-attributes define-crossref-class define-enumeration define-letter-group define-letter-groups define-location-class define-location-class-order define-rule-set define-sort-rule-orientations forward backward info merge-rule merge-to require searchpath sort-rule use-rule-set *indexstyle* )) ;; line 1168 "intface.nw" (eval-when (compile load eval) ;; line 91 "intface.nw" (export '(*indexstyle* *indexstyle-readtable* do-require set-searchpath-by-string *sort-rule-orientations* forward backward *idxstyle-user-interface-definitions* )) ;; line 159 "intface.nw" (export '(stringify list-of-strings-p make-well-formed-list map-to-strings)) ;; line 642 "intface.nw" (export 'flush-ordrules-message-buffer) ;; line 1170 "intface.nw" ) ;; line 557 "idxrule.nw" ;; $Id: idxrule.nw,v 1.10 1997/03/26 16:18:19 kehr Exp $ ;; line 323 "idxrule.nw" (defclass relation () ((rel-sets :accessor get-rel-sets :initform '() ) (rel-hash :accessor get-rel-hash :initform (make-hash-table :test #'equal)))) (defun make-relation () (make-instance 'relation)) ;; line 344 "idxrule.nw" (defmethod rel-insert ((rel relation) x y) (let* ((rel-sets (get-rel-sets rel)) (x-node (assoc x rel-sets)) (y-node (assoc y rel-sets))) (cond ((null x-node) (setf (get-rel-sets rel) (cons (list x y) rel-sets))) ((member y (cdr x-node))) (t (rplacd x-node (cons y (cdr x-node))))) (when (and (null y-node) (not (eql x y))) (setf (get-rel-sets rel) (cons (list y) (get-rel-sets rel))))) rel) (defmethod rel-simple-insert ((rel relation) x) (let* ((rel-sets (get-rel-sets rel)) (x-node (assoc x rel-sets))) (unless x-node (setf (get-rel-sets rel) (cons (list x) rel-sets)))) rel) ;; line 366 "idxrule.nw" (defmethod rel-merge ((rel-1 relation) x) (declare (ignore x)) rel-1) (defmethod rel-merge ((rel-1 relation) (rel-2 relation)) (mapc #'(lambda (r-2) (let ((r-1 (assoc (car r-2) (get-rel-sets rel-1)))) (cond ((null r-1) (setf (get-rel-sets rel-1) (cons r-2 (get-rel-sets rel-1)))) (t (rplacd r-1 (union (cdr r-1) (cdr r-2))))))) (get-rel-sets rel-2)) rel-1) ;; line 387 "idxrule.nw" (defmacro relation-set (rel x) `(CDR (ASSOC ,x (SLOT-VALUE ,rel 'REL-SETS)))) ;; line 408 "idxrule.nw" (defmethod make-ready ((rel relation)) (let ((ht (get-rel-hash rel))) (mapc #'(lambda (node) (mapc #'(lambda (succ-node) (setf (gethash (cons (car node) succ-node) ht) t)) (cdr node))) (get-rel-sets rel))) rel) ;; line 423 "idxrule.nw" (defmacro relation-p (rel x y) `(GETHASH (CONS ,x ,y) (SLOT-VALUE ,rel 'REL-HASH))) ;; line 439 "idxrule.nw" (defun print-relation (rel-sets stream printfunc &key open close headsep listsep) (mapc #'(lambda (from) (when open (format stream open)) (write (funcall printfunc (car from)) :stream stream) (when headsep (format stream headsep)) (mapc #'(lambda (to) (write (funcall printfunc to) :stream stream) (when listsep (format stream listsep))) (cdr from)) (when close (format stream close))) rel-sets)) ;; line 467 "idxrule.nw" (defmethod topsort ((rel relation)) (let ((rel-set (copy-tree (get-rel-sets rel))) (topsort-list '())) (loop (let ((zero-indeg (find-if #'(lambda (x) (null (cdr x))) rel-set))) (when (null zero-indeg) (return)) (let ((zero-indeg-elt (car zero-indeg))) (setq topsort-list (cons zero-indeg-elt topsort-list)) (setq rel-set (delete zero-indeg rel-set :test #'equal)) (mapc #'(lambda (x) (rplacd x (delete zero-indeg-elt (cdr x) :test #'equal))) rel-set))) ) (if (null rel-set) (values topsort-list t) (values nil rel-set)))) ;; line 494 "idxrule.nw" (defmethod transform-relation ((rel relation) transform-func) (let ((new-rel (make-relation))) (mapc #'(lambda (x) (let ((transformed-x (funcall transform-func (car x)))) (mapc #'(lambda (y) (rel-insert new-rel transformed-x (funcall transform-func y))) (cdr x)))) (get-rel-sets rel)) new-rel)) ;; line 511 "idxrule.nw" (defmethod remove-reflexivity ((rel relation)) (mapc #'(lambda (x) (rplacd x (delete (car x) (cdr x) :test #'equal))) (get-rel-sets rel)) rel) ;; line 529 "idxrule.nw" (defmethod transitive-hull ((rel relation)) (setf (get-rel-sets rel) (let ((rel-sets (get-rel-sets rel))) (mapc #'(lambda (j) (mapc #'(lambda (i) (when (member (car j) (cdr i)) (mapc #'(lambda (k) (when (and (member (car k) (cdr j)) (not (member (car k) (cdr i)))) (rplacd (last i) (list (car k))))) rel-sets))) rel-sets)) rel-sets))) rel) ;; line 61 "idxrule.nw" (defclass index-rule () ()) (defclass relation-rule (index-rule relation) ()) ;; line 88 "idxrule.nw" (defclass merge-rule (relation-rule) ()) (defun make-merge-rule () (make-instance 'merge-rule)) ;; line 117 "idxrule.nw" (defclass drop-if-merged-rule (relation-rule) ()) (defun make-drop-if-merged-rule () (make-instance 'drop-if-merged-rule)) ;; line 278 "idxrule.nw" (defclass substitution-rule (relation-rule) ()) (defun make-substitution-rule () (make-instance 'substitution-rule)) ;; line 164 "idxrule.nw" (defclass catattr-groups (index-rule) ((attribute-list :reader get-attribute-list :writer set-attribute-list :initform nil) (attribute-table :reader get-attribute-table :initform (make-hash-table :test #'equal :size 16)))) (defun make-catattr-groups () (make-instance 'catattr-groups)) (defmethod add ((catattr-grp catattr-groups) (catattr category-attribute)) (setf (gethash (get-name catattr) (get-attribute-table catattr-grp)) catattr)) (defmacro lookup-catattr-name (catattr-grp catattr-name) `(GETHASH ,catattr-name (SLOT-VALUE ,catattr-grp 'ATTRIBUTE-TABLE))) ;; line 217 "idxrule.nw" (defun initialize-category-attributes (attribute-list idxcls) (let ((catattr-grps (get-cat-attrs idxcls)) (impl-subst-rule (get-implicit-subst-rules idxcls))) (set-attribute-list attribute-list catattr-grps) (let ((catattr-grp-counter 0) (sort-ordnum-counter 0)) (mapc #'(lambda (sublist) (incf catattr-grp-counter) (let ((last-in-group (lookup-catattr-name catattr-grps (car (last sublist)))) (prev-catattr nil)) (mapc #'(lambda (catattr) (cond ((stringp catattr) (let ((ca (lookup-catattr-name catattr-grps catattr))) (incf sort-ordnum-counter) (set-sort-ordnum sort-ordnum-counter ca) (set-catattr-grp-ordnum catattr-grp-counter ca) (set-last-in-group last-in-group ca) (when prev-catattr (rel-insert impl-subst-rule (lookup-catattr-name catattr-grps prev-catattr) (lookup-catattr-name catattr-grps catattr))) (setq prev-catattr catattr))) (t (error "~A is not a string" catattr)))) sublist))) attribute-list)) catattr-grps)) ;; line 566 "idxrule.nw" (eval-when (compile load eval) ;; line 69 "idxrule.nw" (export '(index-rule relation-rule)) ;; line 96 "idxrule.nw" (export '(merge-rule make-merge-rule)) ;; line 125 "idxrule.nw" (export '(drop-if-merged-rule make-drop-if-merged-rule)) ;; line 185 "idxrule.nw" (export '(catattr-groups make-catattr-groups lookup-catattr-name)) ;; line 252 "idxrule.nw" (export '(initialize-category-attributes catattr-single catattr-mixed)) ;; line 286 "idxrule.nw" (export '(substitution-rule make-substitution-rule)) ;; line 428 "idxrule.nw" (export '(relation make-relation get-rel-sets rel-insert rel-merge make-ready relation-set relation-p)) ;; line 549 "idxrule.nw" (export '(topsort transform-relation remove-reflexivity transitive-hull)) ;; line 568 "idxrule.nw" ) ;; line 873 "idxclass.nw" ;; $Id: idxclass.nw,v 1.20 1997/03/26 16:18:16 kehr Exp $ ;; ;; line 129 "idxclass.nw" (defparameter *locref-cache-size* 1000) (defparameter *locref-cache-rehash-size* 2) (defparameter *locref-cache-hits* 0) (defparameter *locref-cache-misses* 0) ;; line 80 "idxclass.nw" (defclass indexclass () ((name :initarg :name :type string) (basetypes :accessor get-basetypes :initform (make-hash-table :test #'equal :size 10)) (cat-attrs :accessor get-cat-attrs :initform (make-catattr-groups)) (locref-classes :accessor get-locref-classes :initform '() :type list) (xref-classes :accessor get-xref-classes :initform '() :type list) (letter-groups :reader get-letter-groups :initform (make-letter-group-manager)) (partial-order-dict :reader get-partial-order-dict :initform (make-partial-order-dict)) (letter-dict :reader get-letter-dict :initform (make-letter-dict)) (rule-sets :reader get-rule-sets :initform (make-hash-table :test #'equal :size 20)) ;; line 136 "idxclass.nw" (locref-cache :initform (initialize-locref-cache)) ;; line 99 "idxclass.nw" ;; (succ-table :accessor get-succ-table ;; :initform (make-hash-table)) ;; line 219 "idxclass.nw" (merge-rules :reader get-merge-rules :initform (make-merge-rule)) (drop-if-merged-rules :reader get-drop-if-merged-rules :initform (make-drop-if-merged-rule)) ;; (merge-rule-topsort :reader get-merge-rule-topsort ;; :writer set-merge-rule-topsort ;; :initform '()) ;; line 724 "idxclass.nw" (merge-drop-hook :reader get-merge-drop-hook :writer set-merge-drop-hook :initform #'set-state-deleted) ;; line 229 "idxclass.nw" (implicit-subst-rules :reader get-implicit-subst-rules :initform (make-substitution-rule)) (explicit-subst-rules :reader get-explicit-subst-rules :writer set-explicit-subst-rules :initform (make-substitution-rule)) ;; line 776 "idxclass.nw" (implicit-subst-hook :reader get-implicit-subst-hook :writer set-implicit-subst-hook :initform #'transitive-hull) (explicit-subst-hook :reader get-explicit-subst-hook :writer set-explicit-subst-hook :initform #'identity) (global-subst-hook :reader get-global-subst-hook :writer set-global-subst-hook :initform #'identity) (substitution-subst-hook :reader get-substitution-subst-hook :writer set-substitution-subst-hook :initform #'null) ;; line 102 "idxclass.nw" )) (defun make-indexclass (name) (make-instance 'indexclass :name name)) ;; line 253 "idxclass.nw" (defparameter *default-letter-group-definition* "default") (defclass letter-group-definition () ((name :initarg :name :type string) (ordnum :initarg :ordnum :type number))) (defun make-letter-group-definition (name) (make-instance 'letter-group-definition :name name :ordnum 0)) (defclass letter-group-manager () ((prefixes :accessor get-prefixes :initform (make-hash-table :test #'equal)) (letter-groups :accessor get-letter-groups :initform (make-hash-table :test #'equal)) (sort-relation :accessor get-sort-relation :initform (make-relation)) (lookup-list :accessor get-lookup-list :initform '()))) (defun make-letter-group-manager () (let* ((lgm (make-instance 'letter-group-manager)) (letter-groups (get-letter-groups lgm)) (default-group (make-letter-group-definition *default-letter-group-definition*))) (setf (gethash *default-letter-group-definition* letter-groups) default-group) (rel-simple-insert (get-sort-relation lgm) default-group) lgm)) ;; line 295 "idxclass.nw" (defun make-lookup-list (lgm) (setf (get-lookup-list lgm) (let ((lookup-list '())) (maphash #'(lambda (key elt) (push (cons key elt) lookup-list)) (get-prefixes lgm)) (sort lookup-list #'prefix<)))) (defun prefix< (x y) (let ((cx (car x)) (cy (car y))) (let ((same-prefix (string/= cx cy))) (cond ((null same-prefix)) ((> same-prefix 0) (and (= same-prefix (length (car y))))) (t (string< cx cy)))))) ;; line 326 "idxclass.nw" (defun add-letter-group-to-manager (lgm name prefix &key before after) (let* ((prefixes (get-prefixes lgm)) (letter-groups (get-letter-groups lgm)) (letter-group (gethash name letter-groups))) (unless letter-group;; this letter group is unknown -- create one! (setq letter-group (make-letter-group-definition name)) (setf (gethash name letter-groups) letter-group) (rel-simple-insert (get-sort-relation lgm) letter-group)) (let ((current-binding (gethash prefix prefixes))) (and current-binding (not (equal name (get-name current-binding))) (warn "define-letter-group: prefix ~S now maps to letter group ~S" prefix name))) (setf (gethash prefix prefixes) letter-group) (when before (rel-insert (get-sort-relation lgm) letter-group (lookup-letter-group-definition *indexstyle* before))) (when after (rel-insert (get-sort-relation lgm) (lookup-letter-group-definition *indexstyle* after) letter-group))) lgm) (defmethod lookup-letter-group-definition ((idxcls indexclass) (letter string)) (gethash letter (get-letter-groups (get-letter-groups idxcls)))) ;; line 360 "idxclass.nw" (defmethod make-ready ((lgm letter-group-manager)) (make-lookup-list lgm) (let ((sort-relation (get-sort-relation lgm))) (multiple-value-bind (topsorted-list remaining-relation) (topsort sort-relation) (if topsorted-list (let ((ctr 0)) (mapc #'(lambda (grp-def) (setf (get-ordnum grp-def) (incf ctr))) topsorted-list)) (error (concatenate 'string "The user-defined relations for the letter-groups contains cycles!~%The part of the relation containing cycles is" (with-output-to-string (s) (print-relation remaining-relation s #'(lambda (lgdef) (get-name lgdef)) :open "~%" :headsep " before " :listsep " ")))))))) ;; line 388 "idxclass.nw" (defmethod match-letter-group ((idxcls indexclass) (letter string)) (let* ((lgm (get-letter-groups idxcls)) (lookup-list (get-lookup-list lgm)) (match (find-if #'(lambda (prefix-cons) (let* ((prefix (car prefix-cons)) (match-len (string/= prefix letter))) (or (not match-len) #| full match |# (= match-len #| full match with lg |# (length prefix))))) lookup-list)) (letter-group-definition (if match (cdr match);; the corresponding letter-grp-def (lookup-letter-group-definition *indexstyle* *default-letter-group-definition*)))) (gol t "~&Letter-group: ~S -> ~S" letter (get-name letter-group-definition)) letter-group-definition)) ;; line 549 "idxclass.nw" (defclass rule-set () ((name :initarg :name) (rules-list :accessor rules-list :initarg :rules-list) (rules-hash :reader rules-hash :initform (make-hash-table :test #'equal :size 32)) )) (defun make-rule-set (name inherit rules) (unless (every #'(lambda (rule) (and (stringp (car rule));; pattern (stringp (cadr rule)));; replacement ) rules) (error "not a valid rule-set definition!")) (let ((rs (make-instance 'rule-set :name name :rules-list rules))) (let ((rh (rules-hash rs))) (mapc #'(lambda (rule) (setf (gethash (car rule) rh) rule)) rules) (mapc #'(lambda (inh-name) (let ((inh-rs (lookup-rule-set *indexstyle* inh-name))) (when inh-rs (inherit-rule-set rs inh-rs)))) inherit) rs))) #| (add-rule-set *indexstyle* (make-rule-set "foo" '() '(("foo" "bar" :again) ("baz" "bam" :string) ("1" "3")))) (add-rule-set *indexstyle* (make-rule-set "bar" '() '(("1" "bar" :again) ("2" "bam" :string)))) |# (defmacro instantiate-rule-set (run rule-set-names) (let ((rs (make-rule-set "temporary rule-set" rule-set-names '()))) (when rs (cons 'progn (mapcar #'(lambda (rule) `(SORT-RULE ,@rule :RUN ,RUN)) (rules-list rs)))))) (defun inherit-rule-set (rs parent) (let ((rs-hash (rules-hash rs))) (mapc #'(lambda (rule) (let ((pattern (car rule))) (unless (gethash pattern rs-hash) (setf (gethash pattern rs-hash) rule) (setf (rules-list rs) (append (rules-list rs) (list rule)))))) (rules-list parent)) rs)) ;; line 140 "idxclass.nw" (defun initialize-locref-cache () (setq *locref-cache-hits* 0) (setq *locref-cache-misses* 0) (make-hash-table :test #'equal :size *locref-cache-size* :rehash-size *locref-cache-rehash-size*)) (defmethod clear-locref-cache ((idxclass indexclass)) (setf (get-locref-cache idxclass) (initialize-locref-cache))) (defun set-locref-cache-parameters (&key (size 1000) (rehash-size 3)) (when (< size 100) (setq size 100)) (when (< rehash-size 1.5) (setq rehash-size 1.5)) (setq *locref-cache-size* size) (setq *locref-cache-rehash-size* rehash-size)) ;; line 165 "idxclass.nw" (defmacro lookup-locref-cache (idxcls locref-string) `(LET ((LOCREF-LOOKUP (GETHASH ,locref-string (SLOT-VALUE ,idxcls 'LOCREF-CACHE)))) (IF LOCREF-LOOKUP (PROGN (INCF *LOCREF-CACHE-HITS*) (VALUES (CAR LOCREF-LOOKUP) (CDR LOCREF-LOOKUP))) (PROGN (INCF *LOCREF-CACHE-MISSES*) (VALUES NIL NIL))))) (defmethod add-locref-cache ((idxcls indexclass) (locref-string string) (num number) ;; the next one is typeless, since we ;; also want to store the value NIL into ;; it, to denote a mismatch locref) (setf (gethash locref-string (get-locref-cache idxcls)) (cons num locref)) (values num locref)) (defmethod locref-statistics ((idxcls indexclass)) (let ((ht (get-locref-cache idxcls))) (with-output-to-string (s) (format s "Statistics for locref-cache of indexclass ~S:~%" (get-name idxcls)) (format s "Hash-table: size=~A, count=~A, cache-hits=~A, cache-misses=~A, hits=~4,1,,'*F%~%" (hash-table-size ht) (hash-table-count ht) *locref-cache-hits* *locref-cache-misses* (if (> *locref-cache-misses* 0) (* 100 (/ *locref-cache-hits* (+ *locref-cache-hits* *locref-cache-misses*))) 100.0 #| produces an invalid value |#))))) ;; line 430 "idxclass.nw" (defmethod add ((idxcls indexclass) (basetype basetype)) (setf (gethash (get-name basetype) (get-basetypes idxcls)) basetype) idxcls) (defmethod add-alias ((idxcls indexclass) basetype alias-name) (let ((new-basetype (make-copy (lookup-basetype idxcls basetype) alias-name))) (add idxcls new-basetype))) (defmethod add ((idxcls indexclass) (catattr category-attribute)) (add (get-cat-attrs idxcls) catattr) idxcls) ;; line 446 "idxclass.nw" (defun add-letter-groups (idxcls name prefixes &key before after) (let ((lgm (get-letter-groups idxcls))) (mapc #'(lambda (prefix) (add-letter-group-to-manager lgm name prefix :before before :after after)) prefixes))) ;; line 462 "idxclass.nw" (defmethod add ((idxcls indexclass) (loccls layered-location-class)) (let* ((loccls-name (get-name loccls)) (old-loccls (cdr (lookup-locref-class idxcls loccls-name)))) (when old-loccls (remove-location-class idxcls old-loccls)) (if (get-locref-classes idxcls) #| if it is empty, we can't rplacd |# (rplacd (last (get-locref-classes idxcls)) (acons loccls-name loccls nil)) (setf (get-locref-classes idxcls) (acons loccls-name loccls nil)))) idxcls) (defmethod remove-location-class ((idxcls indexclass) (loccls layered-location-class)) (setf (get-locref-classes idxcls) (delete-if #'(lambda (elt) (eq (cdr elt) loccls)) (get-locref-classes idxcls))) idxcls) ;; line 484 "idxclass.nw" (defmethod add ((idxcls indexclass) (xrefcls crossref-location-class)) (let ((xrefcls-name (get-name xrefcls))) (setf (get-xref-classes idxcls) (acons xrefcls-name xrefcls (get-xref-classes idxcls))) idxcls)) ;; line 495 "idxclass.nw" (defmethod add-merge-rule ((idxcls indexclass) (catattr-1 category-attribute) (catattr-2 category-attribute)) (rel-insert (get-merge-rules idxcls) catattr-1 catattr-2) idxcls) (defmethod add-drop-if-merged-rule ((idxcls indexclass) (catattr-1 category-attribute) (catattr-2 category-attribute)) (rel-insert (get-merge-rules idxcls) catattr-1 catattr-2) (rel-insert (get-drop-if-merged-rules idxcls) catattr-1 catattr-2) idxcls) ;; line 512 "idxclass.nw" (defmethod add-implicit-substitution-rule ( (idxcls indexclass) (catattr-1 category-attribute) (catattr-2 category-attribute)) (rel-insert (get-implicit-subst-rules idxcls) catattr-1 catattr-2) idxcls) (defmethod add-explicit-substitution-rule ( (idxcls indexclass) (catattr-1 category-attribute) (catattr-2 category-attribute)) (rel-insert (get-explicit-subst-rules idxcls) catattr-1 catattr-2) idxcls) ;; line 609 "idxclass.nw" (defmethod add-rule-set ((idxcls indexclass) (rs rule-set)) (let ((rule-sets (get-rule-sets idxcls)) (rs-name (get-name rs))) (setf (gethash rs-name rule-sets) rs))) ;; line 635 "idxclass.nw" (defmethod lookup-basetype ((idxcls indexclass) (basetype-name string)) (gethash basetype-name (get-basetypes idxcls))) (defmethod lookup-catattr ((idxcls indexclass) (catattr-name string)) (lookup-catattr-name (slot-value idxcls 'cat-attrs) catattr-name)) (defmethod lookup-location-class ((idxcls indexclass) (loccls-name string)) (or (lookup-crossref-class idxcls loccls-name) (lookup-locref-class idxcls loccls-name))) (defmethod lookup-crossref-class ((idxcls indexclass) (xref-name string)) (assoc xref-name (slot-value idxcls 'xref-classes) :test #'equal)) (defmethod lookup-locref-class ((idxcls indexclass) (loccls-name string)) (assoc loccls-name (slot-value idxcls 'locref-classes) :test #'equal)) (defmethod lookup-rule-set ((idxcls indexclass) (rule-set-name string)) (gethash rule-set-name (get-rule-sets idxcls))) ;; line 685 "idxclass.nw" (defmacro map-location-classes (idxcls apply-func &rest arguments) `(LET () (APPLY #'NCONC (MAPCAR #'(LAMBDA (ELT) (LET ((RES (FUNCALL ,apply-func ,idxcls (CDR ELT) #|ELT is ("name".))|# ,@arguments))) (WHEN RES (LIST RES)))) (GET-LOCREF-CLASSES ,idxcls))))) ;; line 800 "idxclass.nw" (defmethod apply-substitution-hooks ((idxcls indexclass)) (let ((impl (get-implicit-subst-rules idxcls)) (expl (get-explicit-subst-rules idxcls))) (funcall (get-implicit-subst-hook idxcls) impl) (funcall (get-explicit-subst-hook idxcls) expl) (rel-merge impl expl) (set-explicit-subst-rules nil idxcls) (funcall (get-global-subst-hook idxcls) impl) (make-ready impl) )) ;; line 838 "idxclass.nw" (defmethod make-ready ((idxcls indexclass)) (apply-substitution-hooks idxcls) (make-ready (get-merge-rules idxcls)) (make-ready (get-drop-if-merged-rules idxcls)) (make-ready (get-letter-groups idxcls)) ;; (set-merge-rule-topsort (topsort ;; (remove-reflexivity ;; (transform-relation ;; (get-drop-if-merged-rules idxcls) ;; #'(lambda (attr) ;; (get-ordnum attr))))) ;; *indexstyle*) ;;(pprint (get-drop-if-merged-rules idxcls)) ;;(pprint (topsort (get-drop-if-merged-rules idxcls))) (let ((counter 0)) (mapc #'(lambda (catattr) (set-processing-ordnum (incf counter) catattr)) (reverse (topsort (get-drop-if-merged-rules idxcls))))) idxcls) ;; line 888 "idxclass.nw" (eval-when (compile load eval) ;; line 109 "idxclass.nw" (export '(indexclass make-indexclass get-name get-basetypes get-cat-attrs get-xref-classes get-succ-table get-locref-classes get-rule-sets ;; line 241 "idxclass.nw" get-merge-rules get-drop-if-merged-rules ; get-merge-rule-topsort set-merge-rule-topsort get-implicit-subst-rules set-implicit-subst-rules get-explicit-subst-rules set-explicit-subst-rules ;; line 115 "idxclass.nw" )) ;; line 204 "idxclass.nw" (export '(locref-cache-size* *locref-cache-rehash-size* initialize-locref-cache clear-locref-cache lookup-locref-cache add-locref-cache locref-statistics)) ;; line 409 "idxclass.nw" (export '(letter-group-definition match-letter-group)) ;; line 530 "idxclass.nw" (export '(add set add-letter-groups add-merge-rule add-drop-if-merged-rule add-implict-substitution-rule add-explicit-substitution-rule)) ;; line 616 "idxclass.nw" (export '(rule-set make-rule-set add-rule-set instantiate-rule-set inherit-rule-set)) ;; line 656 "idxclass.nw" (export '(lookup-basetype lookup-catattr lookup-letter-group-definition lookup-location-class lookup-crossref-class lookup-locref-class lookup-rule-set)) ;; line 700 "idxclass.nw" (export 'map-location-classes) ;; line 730 "idxclass.nw" (export '(get-merge-drop-hook set-merge-drop-hook)) ;; line 791 "idxclass.nw" (export '(get-implicit-subst-hook set-implicit-subst-hook get-explicit-subst-hook set-explicit-subst-hook get-global-subst-hook set-global-subst-hook get-substitution-subst-hook set-substitution-subst-hook)) ;; line 823 "idxclass.nw" (export '(apply-substitution-hooks)) ;; line 865 "idxclass.nw" (export '(make-ready)) ;; line 890 "idxclass.nw" ) ;; line 54 "idxstyle.nw" (defun create-indexclass (idxcls-name) (setq *indexstyle* (make-indexclass idxcls-name))) ;; line 259 "letters.nw" ;; $Id$ ;; line 37 "letters.nw" (defclass letter () ((name :initarg :name :type string) (props :initarg :props :type list))) (defun make-letter (name properties inherits-from) (make-instance 'letter :name name :props (if inherits-from (append properties (get-props inherits-from)) properties))) (defun find-prop (letter prop) (assoc prop (get-props letter))) ;; line 53 "letters.nw" (defclass letter-dictionary () ((letters :initform (make-hash-table :test #'equal)))) (defun make-letter-dict () (make-instance 'letter-dictionary)) (defun find-letter* (dict-ht letter) (gethash letter dict-ht)) (defun find-letter (dict letter) (gethash letter (get-letters dict))) (defun add-letter-to-dict (letter-dict po-dict name props &optional inherits) (let ((dict-ht (get-letters letter-dict))) (when (gethash name dict-ht) (nraw "Letter `~S' redefined!" name)) (setf (gethash name dict-ht) (make-letter name (pre-calculate-props props po-dict) (when inherits (find-letter* dict-ht name)))))) ;; line 85 "letters.nw" (defun pre-calculate-props (props po-dict) (mapc #'(lambda (po-spec) (let ((po-name (car po-spec)) (po-val (cadr po-spec))) (setf (cdr (last po-spec)) (list (find-prop-weight (find-partial-order po-dict po-name) po-val))))) props) props) ;; line 98 "letters.nw" (defmacro define-letter (&whole whole &rest rest) (destructuring-switch-bind (name &rest proplist) rest (cond ;; line 239 "intface.nw" ((null name) (error "missing argument in `~S' !" whole)) ((not (or (symbolp name) (stringp name))) (error "~S is not a symbol or a string in `~S' !" name whole)) ;; line 102 "letters.nw" ((not (listp proplist)) (error "~S is not a property list in ~S." proplist whole)) (t `(LET ((NAME (STRINGIFY ',name))) (ADD-LETTER-TO-DICT (GET-LETTER-DICT *INDEXSTYLE*) (GET-PARTIAL-ORDER-DICT *INDEXSTYLE*) ,name ',proplist)))))) ;; line 119 "letters.nw" (defclass partial-order () ((name :initarg :name :type string) (order :initform (make-hash-table :test #'equal)) (direct :initarg :direct :type symbol))) (defun make-partial-order (name order &optional (direct :from-start)) (let* ((po (make-instance 'partial-order :name name :direct direct)) (po-ht (get-order po)) (ctr 0)) (mapc #'(lambda (elt) (when (gethash elt po-ht) (error "Element ~S doubly defined in partial order ~S." elt name)) (setf (gethash elt po-ht) (incf ctr))) order) po)) ;; line 140 "letters.nw" (defclass partial-order-dictionary () ((order :initform (make-hash-table :test #'equal)))) (defun make-partial-order-dict () (make-instance 'partial-order-dictionary)) (defun find-partial-order (dict po-name) (gethash po-name (get-order dict))) (defun find-prop-weight (po po-name) (gethash po-name (get-order po))) (defun add-partial-order-to-dict (dict po-name po-order po-direct) (let ((dict-ht (get-order dict))) (when (gethash po-name dict-ht) (nraw "Partial order ~S redefined!" po-name)) (setf (gethash po-name dict-ht) (make-partial-order po-name po-order po-direct)))) ;; line 161 "letters.nw" (defmacro define-partial-order (&whole whole &rest rest) (destructuring-switch-bind (name ordlist &switch from-start from-end) rest (cond ;; line 239 "intface.nw" ((null name) (error "missing argument in `~S' !" whole)) ((not (or (symbolp name) (stringp name))) (error "~S is not a symbol or a string in `~S' !" name whole)) ;; line 169 "letters.nw" ((not (listp ordlist)) (error "~S is not a partial order list in ~S." ordlist whole)) ((and from-start from-end) (error "Only one of :from-start or :from-end is allowed in ~S." whole)) (t `(LET ((NAME (STRINGIFY ',name))) (ADD-PARTIAL-ORDER-TO-DICT (GET-PARTIAL-ORDER-DICT *INDEXSTYLE*) ,name ',ordlist ,(if (or from-start (not from-end)) :from-start :from-end))))))) ;; line 194 "letters.nw" (defun word-cmp (word1 word2 po) (let ((po-name (get-name po)) let1 let2 weight1 weight2) (loop (cond ((and (endp word1) (endp word2)) (return :equal)) ((endp word1) (return :less)) ((endp word2) (return :greater)) (t (setq let1 (car word1)) (setq word1 (cdr word1)) (setq let2 (car word2)) (setq word2 (cdr word2)) (setq weight1 (lookup-letter-weight let1 po-name)) (setq weight2 (lookup-letter-weight let2 po-name)) (when (< weight1 weight2) (return :less)) (when (> weight1 weight2) (return :greater))))))) (defun calc-list-of-weights (word po) (let ((po-name (get-name po))) (mapcar #'(lambda (letter) (lookup-letter-weight letter po-name)) word))) ;; line 227 "letters.nw" (defun lookup-letter-weight (letter po-name) (let ((prop (find-prop letter po-name))) (if prop (car (last prop)) (find-prop-weight (find-partial-order (get-partial-order-dict *indexstyle*) po-name) 'others)))) ;; line 237 "letters.nw" (defun make-word (letter-list) (let ((dict (get-letter-dict *indexstyle*))) (mapcar #'(lambda (str) (find-letter dict str)) letter-list))) (defun sort-words (word-list po) (split-list #'(lambda (word) (calc-list-of-weights word po)) word-list)) ;; line 99 "idxstyle.nw" (create-indexclass "default") ;; line 107 "idxstyle.nw" (defmacro string-expand (str) (let ((str-expansion (map 'list #'(lambda (c) (make-string 1 :initial-element c)) str))) `(QUOTE ,str-expansion))) (define-alphabet* "ALPHA" (string-expand "ABCDEFGHIJKLMNOPQRSTUVWXYZ")) (define-alphabet* "alpha" (string-expand "abcdefghijklmnopqrstuvwxyz")) (define-alphabet* "digits" (string-expand "0123456789")) ;; line 128 "idxstyle.nw" (defun prefix-match-for-radix-numbers (str radix) (let* ((n nil) (strlen (length str)) (len-match (do ((i 0 (1+ i))) ((or (>= i strlen) (not (digit-char-p (char str i) radix))) i) (setq n (+ (* (if n n 0) radix) (digit-char-p (char str i) radix)))))) (values (subseq str 0 len-match) (subseq str len-match) n))) ;; line 155 "idxstyle.nw" (define-enumeration "arabic-numbers" #'(lambda (str) (prefix-match-for-radix-numbers str 10)) "0123456789") ;; line 178 "idxstyle.nw" (defparameter *lowercase-roman-numbers-lookup-table* '((#\i ("ix" . 9) ("iv" . 4) ("iiii" . 4) ("iii". 3) ("ii" . 2) ("i" . 1)) (#\v ("viiii" . 9) ("viii" . 8) ("vii" . 7) ("vi" . 6) ("v" . 5)) (#\x ("xc" . 90) ("xl" . 40) ("x" . 10)) (#\m ("m" . 1000)) (#\c ("cm" . 900) ("cd" . 400) ("c" . 100)) (#\l ("lxxxx" . 90) ("lxxx" . 80) ("lxx" . 70) ("lx" . 60) ("l" . 50)) (#\d ("dcccc" . 900) ("dccc" . 800) ("dcc" . 700) ("dc" . 600) ("d" . 500)) )) (defparameter *uppercase-roman-numbers-lookup-table* '((#\I ("IX" . 9) ("IV" . 4) ("IIII" . 4) ("III". 3) ("II" . 2) ("I" . 1)) (#\V ("VIIII" . 9) ("VIII" . 8) ("VII" . 7) ("VI" . 6) ("V" . 5)) (#\X ("XC" . 90) ("XL" . 40) ("X" . 10)) (#\M ("M" . 1000)) (#\C ("CM" . 900) ("CD" . 400) ("C" . 100)) (#\L ("LXXXX" . 90) ("LXXX" . 80) ("LXX" . 70) ("LX" . 60) ("L" . 50)) (#\D ("DCCCC" . 900) ("DCCC" . 800) ("DCC" . 700) ("DC" . 600) ("D" . 500)) )) ;; line 206 "idxstyle.nw" (defun roman-number-prefix-match (roman-number-string *table*) (let ((result 0) (str roman-number-string) (last-val 100000) #| hope that's enough |# (str-len (length roman-number-string)) ch table match-cons curr-val ) (loop (when (= 0 (length str)) (return (values roman-number-string "" result))) (setq ch (aref str 0)) (setq table (cdr (assoc ch *table*))) (setq match-cons (find-if #'(lambda (cons) (let* ((prefix (car cons)) (match-len (string/= prefix str))) (or (not match-len) (= match-len (length prefix))))) table)) (unless match-cons (return (if (= 0 result) (values nil nil nil) (values (subseq roman-number-string 0 (- str-len (length str))) str result)))) (setq curr-val (cdr match-cons)) (when (> curr-val last-val) (return (values (subseq roman-number-string 0 (- str-len (length str))) str result))) (incf result curr-val) (setq last-val curr-val) (setq str (subseq str (length (car match-cons))))))) ;; line 241 "idxstyle.nw" (define-enumeration "roman-numbers-uppercase" #'(lambda (str) (roman-number-prefix-match str *uppercase-roman-numbers-lookup-table*)) "IVXLCDM") (add-alias *indexstyle* "roman-numbers-uppercase" "ROMAN") (add-alias *indexstyle* "roman-numbers-uppercase" "roman-numerals-uppercase") (define-enumeration "roman-numbers-lowercase" #'(lambda (str) (roman-number-prefix-match str *lowercase-roman-numbers-lookup-table*)) "ivxlcdm") (add-alias *indexstyle* "roman-numbers-lowercase" "roman") (add-alias *indexstyle* "roman-numbers-lowercase" "roman-numerals-lowercase") ;; line 902 "idxclass.nw" #+:XP (defmacro pprint-slot-block (slot-name body) `(progn (pprint-logical-block (s nil :suffix " }") (pprint-indent :block 2 s) (write-string ,slot-name s) (pprint-newline :mandatory s) ,body) (pprint-newline :mandatory s))) #+:XP (defmacro pprint-slot-block-line (slot-name body) `(progn (pprint-logical-block (s nil :suffix " }") (pprint-indent :block 2 s) (write-string ,slot-name s) (pprint-newline :linear s) ,body) (pprint-newline :mandatory s))) ;; line 924 "idxclass.nw" #+:XP (set-pprint-dispatch 'indexclass #'(lambda (s idxcls) (pprint-logical-block (s nil :suffix "}") (pprint-indent :block 2 s) (write-string "indexclass " s) (write (get-name idxcls) :stream s) (write-string " {" s) (pprint-newline :mandatory s) (pprint-slot-block "basetypes {" (maphash #'(lambda (key bt) (declare (ignore key)) (write (get-name bt) :stream s) (write-string " " s) (pprint-newline :linear s)) (get-basetypes idxcls))) (pprint-slot-block "cat-attrs {" (write (get-cat-attrs idxcls) :stream s)) (pprint-slot-block "locclasses {" (mapc #'(lambda (lc) (write (get-name (cdr lc)) :stream s) (write-string " [" s) (write (get-ordnum (cdr lc)) :stream s) (write-string "] " s) (pprint-newline :linear s)) (get-locref-classes idxcls))) (pprint-slot-block "xrefclasses {" (mapc #'(lambda (lc) (write (get-name (cdr lc)) :stream s) (write-string " [" s) (write (get-ordnum (cdr lc)) :stream s) (write-string "] " s) (pprint-newline :linear s)) (get-xref-classes idxcls))) (write (get-letter-dict idxcls) :stream s) (pprint-newline :mandatory s) (write (get-partial-order-dict idxcls) :stream s) (pprint-newline :mandatory s) (pprint-slot-block "merge-rules {" (write (get-merge-rules idxcls) :stream s)) (pprint-slot-block "drop-if-merged-rules {" (write (get-drop-if-merged-rules idxcls) :stream s)) ;; (pprint-slot-block-line ;; "merge-rule-topsort { " ;; (write (get-merge-rule-topsort idxcls) :stream s)) (pprint-slot-block "implicit-subst-rules {" (write (get-implicit-subst-rules idxcls) :stream s)) (pprint-slot-block "explicit-subst-rules {" (write (get-explicit-subst-rules idxcls) :stream s)) (pprint-slot-block-line "implicit-subst-hook {" (write (get-implicit-subst-hook idxcls) :stream s)) (pprint-slot-block-line "explicit-subst-hook {" (write (get-explicit-subst-hook idxcls) :stream s)) (pprint-slot-block-line "global-subst-hook {" (write (get-global-subst-hook idxcls) :stream s)) (pprint-slot-block-line "substitution-subst-hook {" (write (get-substitution-subst-hook idxcls) :stream s)) (pprint-slot-block-line "merge-drop-hook {" (write (get-merge-drop-hook idxcls) :stream s)) ; (pprint-slot-block ; "keyword-markup {" ; (write (get-keyword-markup idxcls) :stream s)) ))) ;; line 580 "idxrule.nw" #+:XP (defun pprint-relation (s rel) (pprint-logical-block (s nil :suffix "}") (pprint-indent :block 2 s) (write-string "Relation { " s) (pprint-logical-block (s nil) (pprint-indent :block 2) (mapc #'(lambda (x) (when x (write (car x) :stream s) (write-string " ->" s) (mapc #'(lambda (y) (write-string " " s) (write y :stream s)) (cdr x)) (pprint-newline :mandatory s))) (get-rel-sets rel))))) #+:XP (set-pprint-dispatch 'relation-rule #'pprint-relation) #+:XP (set-pprint-dispatch 'relation #'pprint-relation) ;; line 606 "idxrule.nw" #+:XP (set-pprint-dispatch 'catattr-groups #'(lambda (s catgrp) (pprint-logical-block (s nil :suffix "}") (pprint-indent :block 2 s) (write-string "Category-attribute-group { " s) (pprint-newline :mandatory s) (write (get-attribute-list catgrp) :stream s) (pprint-newline :mandatory s) (write (get-attribute-table catgrp) :stream s)))) ;; line 277 "letters.nw" #+:XP (set-pprint-dispatch 'letter #'(lambda (s lt) (pprint-logical-block (s nil :suffix ">") (pprint-indent :block 2 s) (write-string "<" s) (write (get-name lt) :stream s) (write-string " " s) (pprint-newline :linear s) (write (get-props lt) :stream s)))) #+:XP (set-pprint-dispatch 'letter-dictionary #'(lambda (s dict) (pprint-logical-block (s nil :suffix "}") (pprint-indent :block 2 s) (write-string "letters {" s) (maphash #'(lambda (key lt) (declare (ignore key)) (write lt :stream s) (write-string " " s) (pprint-newline :linear s)) (get-letters dict))))) #+:XP (set-pprint-dispatch 'partial-order #'(lambda (s po) (pprint-logical-block (s nil :suffix ">") (pprint-indent :block 2 s) (write-string "<" s) (write (get-name po) :stream s) (pprint-newline :linear s) (maphash #'(lambda (key po) (write-string " [" s) (write key :stream s) (write-string " " s) (write po :stream s) (write-string "]" s) (pprint-newline :linear s)) (get-order po))))) #+:XP (set-pprint-dispatch 'partial-order-dictionary #'(lambda (s dict) (pprint-logical-block (s nil :suffix "}") (pprint-indent :block 2 s) (write-string "partial-orders {" s) (maphash #'(lambda (key po) (declare (ignore key)) (write po :stream s) (write-string " " s) (pprint-newline :linear s)) (get-order dict))))) ;; line 321 "idxstyle.nw" (defvar *RCS-Identifier* '( ;; line 894 "idxclass.nw" ("idxclass" . "$Id: idxclass.nw,v 1.20 1997/03/26 16:18:16 kehr Exp $") ;; line 572 "idxrule.nw" ("idxrule" . "$Id: idxrule.nw,v 1.10 1997/03/26 16:18:19 kehr Exp $") ;; line 335 "idxstyle.nw" ("idxstyle" . "$Id: idxstyle.nw,v 1.19 1997/03/26 16:18:23 kehr Exp $") ;; line 1174 "intface.nw" ("intface" . "$Id: intface.nw,v 1.30 1997/10/20 11:25:09 kehr Exp $") ;; line 269 "letters.nw" ("letters" . "$Id$") ;; line 321 "idxstyle.nw" )) (eval-when (compile load eval) ;; line 59 "idxstyle.nw" (export 'create-indexclass) ;; line 89 "idxstyle.nw" (export '*load-paths*) ;; line 325 "idxstyle.nw" )