;;;### File "toplevel.lisp" ;;; packed file: "rfi.lisp" ;;; last update: see variable *rfi-version* ;;; R E L A T I O N A L / F U N C T I O N A L I N T E R P R E T E R (RFI) ;;; ;;; Harold Boley ;;; ;;; University of Kaiserslautern ;;; ;;; http://www.relfun.org ;;; Thanks for contributions to Simone Andel, Massimiliano Campagnoli, ;;; Michael Christen, Klaus Elsbernd, Andreas Gilbert, Wolfgang Goerigk, ;;; Victoria Hall, Hans-Guenther Hein, Michael Herfert, Knut Hinkelmann, ;;; Ulrich Hoffmann, Thomas Labisch, Markus Perling, Ralph Scheubrein, ;;; Michael Sintek, Werner Stein, and Stefan Steinacker. ;;; Copyright Notice ;;; ;;; This software is distributed for non-profit and research purposes only. ;;; I retain the exclusive right of producing a commercial version from it. ;;; Non-profit redistribution of the current version or parts of the ;;; current version is permitted if this copyright notice is included ;;; unchanged. I give no warranty of any kind for this prototype. It will be ;;; further improved as time permits. ;;; ;;; Copyright (c) 2000 by Harold Boley ; ----------------------------------------------------------------------------- ; ; defining the global variables ; ; ----------------------------------------------------------------------------- (defvar *rfi-version* "24 Apr 2000" "date of this version") (defvar *rfi-commands* nil "list with valid interpreter-commands ") (defvar *rfi-database* nil "user programs ") (defvar *ll-db* nil "LISP light database ") (defvar *rfi-input-mode* nil "selects input mode ") (defvar *rfi-machine* nil "specifies interpreter or emulator mode") (defvar *rfi-ori* nil "stores last user-query ") (defvar *rf-print-width* nil "width of the screen ") (defvar *style* #+rf-lisp2pro 'prolog ; default style prolog #-rf-lisp2pro 'lisp ) (defvar *rfi-prompt* nil "prompt-sign ") (defvar *rfi-readtable* nil "readtable for special symbols ") (defvar *rfi-script-input* nil "input stream for typescript ") (defvar *rfi-script-output* nil "output stream for typescript ") (defvar *rfi-showdepth* nil "length of the trace ") (defvar *rfi-spy* nil "true if programflow is traced ") (defvar *rfi-standard-output* nil "output stream ") (defvar *rfi-standard-input* nil "input stream ") (defvar *rfi-static* nil "true if database is flattened ") (defvar *sortstyle* 'static "static or dynamic sorts ") (defvar *emu-debug* nil "flag for emulator-debugger ") (defvar *classified-database* nil "classified clauses ") (defvar *lisp-functions* nil "allowed functions ") (defvar *lisp-predicates* nil "allowed predicates ") (defvar *lisp-extras* nil "allowed extra-logicals ") (defvar *relfun-extras* nil "allowed relfun-extensions ");(Klaus 30.09.1990) (defvar *tcl* nil "flag for tcl/tk user interface ") (defvar *rfi-help-dir* #+our-fs (namestring (our-fs:logdir-dir :RF-Help)) #-our-fs "./help/" "help directory for help texts") (defvar *timermode* nil "<==> Print informations about execution time." ) (defvar *timers* nil "An a-list associating timer symbols with timer values." ) (defvar *defer-module-browser-updates* nil) (defconstant *esc* (code-char 27)) ; ----------------------------------------------------------------------------- ; ; Redefining symbol-function via explicit funcallable declarations (WG) ; ; ----------------------------------------------------------------------------- ; transition from symbol to #'symbol must be at compile time #+CLiCC (progn (defvar *funcallable* nil) (defmacro declare-funcallable (&rest syms) ; MS `(setq *funcallable* (append (list ,@(make-fassoc syms)) *funcallable*))) (defun make-fassoc (syms) (if (null syms) nil `((cons (quote ,(car syms)) (function ,(car syms))) ,@(make-fassoc (cdr syms))))) (defun symbol-function (sym) ; CLiCC version of CL's symbol functionalizer (let ((funl (assoc sym *funcallable*))) (unless funl (error "undeclared funcallable function ~a~%" sym)) (cdr funl))) ) ; ----------------------------------------------------------------------------- ; ; main-functions of the interpreter ; ; ----------------------------------------------------------------------------- #-(or CLiCC kcl) (defmacro rf-ignore-errors (&body body) "evaluate body encapsulating LISP errors and printing them as RELFUN errors" `(let ((result (multiple-value-list (ignore-errors ,@body)))) (if (and (null (car result)) (typep (cadr result) 'error)) (rf-error "- " (format nil "~A" (cadr result))) (car result)))) #+(or CLiCC kcl) (defmacro rf-ignore-errors (&body body) `(progn ,@body)) (defun relfun (&optional *rfi-script-input* (*rfi-input-mode* 'interactive)) ; (rfi-init) ; not allowed because of recursive relfun-calls (tracer-reset-to-zero) #+our-fs ; determine default directory when starting relfun for the first time (unless (boundp '*rf-non-first*) (rfi-cd nil) ; reset and display if tcl is available (setq *rf-non-first* t)) ; in kcl *standard-input* is redirected while loading init.lsp: (setq *rfi-standard-input* *standard-input*) (rf-terpri) (do* ((leave-relfun nil) (userline '(relfun))) (leave-relfun) (setq userline ; execute command/query and bind new input from user (catch :toploop (rf-ignore-errors (if (ll-mode-p) ; ll (LISP light) mode (cond ((ll-command-p userline) (setq leave-relfun (ll-command userline)) (cond (leave-relfun nil) ((eq (car userline) 'ori) *rfi-ori*) (t (readl)))) ((and (listp (car userline)) (eq (caar userline) 'defun)) (catch 'stop (compile-ll-db userline)) ; db = ((defun ...)) (readl)) (t (setq *rfi-ori* userline) (catch 'stop (compile-ll-db (list (list* 'defun '%llquery () userline))) (llrun '%llquery)) (readl))) ; rfi, rfe or rfc mode (cond ((rfi-command-p userline) (setq leave-relfun (rfi-command userline)) (cond (leave-relfun nil) ((eq (car userline) 'ori) *rfi-ori*) (t (readl)))) (t ;;; ;;; query ;;; (setq *rfi-ori* userline) (cond ((rfi-interpreter-mode-p) ;;; ;;; use interpreter to answer query ;;; (progn (setq *gensym-counter* 1) (speedup-check) (rf-timer-start) (cond ((and-process (deanon-request (if *rfi-static* (flatten-request userline) userline)) '((bottom)) (collect-databases) 1 nil)) ; corresponding rf-timer-stop in more-p (t (rf-print '|unknown|) (rf-timer-stop) (readl))))) ;;; ;;; use emulator to answer query ;;; ; more-p used in emulator MS 8/93 ((rfi-emulator-mode-p) (progn (rf-timer-start) (cond ((emulate (transform-query-for-emulator userline))) ; corresponding rf-timer-stop in more-p (t (rf-print '|unknown|) (rf-timer-stop) (readl))))) ;;; ;;; use external WAM to answer query MP 5/96 ;;; ((rfi-emuc-mode-p) (progn (rf-timer-start) (cond ((emuc (transform-query-for-emulator userline))) ; corresponding rf-timer-stop in more-p (t (rf-print '|unknown|) (rf-timer-stop) (readl))))))))))))) (if (streamp *rfi-script-input*) (close *rfi-script-input*)) ) (defun collect-databases () "Returns a list of the system modules (sortbase prelude tracebase), the current module, and its preorder-flattened context modules." (mod-collect-databases) ) (defun rfi-command-p (userline) (member (car userline) *rfi-commands* :test #'equal) ) (defun rfi-command (userline) (let ((com (car userline))) (cond ((eq com 'a0) (set-database (append (cdr userline) (get-database)))) ((eq com 'a0ft) (set-database (cons (cons 'ft (cdr userline)) (get-database)))) ((eq com 'a0hn) (set-database (cons (cons 'hn (cdr userline)) (get-database)))) ((eq com 'az) (set-database (append (get-database) (cdr userline)))) ((eq com 'azft) (set-database (append (get-database) (list (cons 'ft (cdr userline)))))) ((eq com 'azhn) (set-database (append (get-database) (list (cons 'hn (cdr userline)))))) ((eq com 'timermode) (rfi-cmd-timermode userline)) ((eq com 'size) (rf-print (list 'clauses (length (get-database)))) (rf-print (list 'literals (- (apply #'+ (mapcar #'length (get-database))) (length (get-database)))))) ((eq com 'version) (rf-print *rfi-version*)) ((eq com 'builtins) (rf-pprint (mkk-inst (list 'tup (cons 'functions *lisp-functions*) (cons 'predicates *lisp-predicates*) (cons 'extras *lisp-extras*))))) ((eq com 'modes) (rfi-modes userline)) ((eq com 'normalize) ; database normalization through simplification (TK 07.10.1990): (set-database (normalize-database (get-database)))) ((eq com 'horizon) (set-database (horizon-database (get-database)))) ((eq com 'verti) (llc+) (rfi-cmd-compile userline) (gwam.assem)) ((eq com 'compile) (llc+) ; LISP light compiler (setq *rfi-database* (horizon-database *rfi-database*)) (rfi-cmd-compile userline) (gwam.assem)) ;userline still ignored in assembling!!!!! ((eq com 'classify) (setq *rfi-database* (horizon-database *rfi-database*)) (rfi-cmd-classify (select-clauses-of (cadr userline)))) ((eq com 'codegen) (llc+) (rfi-cmd-codegen) (gwam.assem)) ;userline still ignored in assembling!!!!! ((eq com 'quitwam) (rfi-cmd-quitwam)) ((eq com 'cd) (rfi-cd (cadr userline))) ((eq com 'pwd) (rfi-pwd)) ((eq com 'ls) (rfi-ls (cdr userline))) ((eq com '!!) (rfi-shell (cdr userline))) ((eq com 'consult) (rfi-cmd-consult userline)) ((eq com 'destroy) (rfi-cmd-destroy)) ((eq com 'dynamic) (setq *rfi-static* nil)) ((eq com 'edit) (rfi-cmd-edit userline)) ((eq com 'emuc) (rfi-cmd-emuc)) ((eq com 'emul) (rfi-cmd-emul userline)) ;;; command endscript defined in function readl ((eq com 'exec) (rfi-cmd-execute userline)) ((eq com 'deanon) (set-database (deanon-database (get-database)))) ((eq com 'flatten) (set-database (flatten-database (get-database)))) ((eq com 'flatter) (set-database (flatten-struc-database (get-database)))) ((eq com 'extrarg) (set-database (extrarg-database (get-database)))) ((eq com 'relationalize) (set-database (extrarg-database (passtup (flatten-database (get-database)))))) ((eq com 'singlify) (set-database (singlify-database (get-database)))) ((eq com 'footen) (set-database (footen-database (cdr userline) (get-database)))) ((eq com 'footer) (set-database (footer-database (cdr userline) (get-database)))) ((eq com 'uncertain) (uncertain-db (cadr userline))) ; V. Hall ((eq com 'help) (rfi-cmd-help userline)) ((eq com 'inter) (rfi-cmd-inter)) ((eq com 'pausebye) (rfi-change-prelude '(hn (pause)) '(hn (pause) (relfun)))) ((eq com 'nopausebye) (rfi-change-prelude '(hn (pause) (relfun)) '(hn (pause)))) ((eq com 'prelude) (when *tcl* (format t "~a{Eval:set listingof prelude~a}" *esc* *esc*)) (rfi-cmd-l (cadr userline) (get-sysbase 'prelude))) ((or (eq com 'l) (eq com 'listing)) (when *tcl* (let ((*print-case* :downcase)) (format t "~a{Eval:set listingof ~a~a}" *esc* *current-module* *esc*))) (rfi-cmd-l (cadr userline) (get-database) *ll-db*)) ((eq com 'lconsult) (rfi-cmd-lconsult userline)) ((eq com 'listclass) (rfi-cmd-listclass userline)) ((eq com 'listcode) (rfi-cmd-listcode userline)) ((eq com 'll) ; M.Sintek (rfi-cmd-ll)) ((eq com 'fd2ll) (fd2ll)) ((eq com 'deta) (let ((new-db*ll-db (split-relfun-db (get-database) *lisp-functions* *lisp-predicates*))) (set-database (car new-db*ll-db)) (setq *ll-db* (append *ll-db* (cadr new-db*ll-db))))) ((eq com 'llc) (llc)) ((eq com 'lreplace) (rfi-cmd-lreplace userline)) ((eq com 'ltell) (set (cadr userline) (get-database))) ((or (eq com 'm) (eq com 'more)) (rf-print '|unknown|)) ((eq com 'nospy) (setq *rfi-spy* nil) (setq *emu-debug* nil)) ((eq com 'rx) (set-database (remove (cadr userline) (get-database) :test #'equal))) ((eq com 'rxft) (set-database (remove (cons 'ft (cdr userline)) (get-database) :test #'equal))) ((eq com 'rxhn) (set-database (remove (cons 'hn (cdr userline)) (get-database) :test #'equal))) ((eq com 'replace) (rfi-cmd-destroy) (rfi-cmd-replace userline)) ((eq com 'script) (rfi-cmd-startscript userline)) ((eq com 'showdepth) (rfi-cmd-showdepth userline)) ((eq com 'spy) (setq *rfi-spy* t) (setq *emu-debug* t)) ((eq com 'static) (setq *rfi-static* t)) ((eq com 'tell) (rfi-cmd-tell userline)) ((eq com 'untup) (set-database (untup-database (get-database)))) ((eq com 'fc-init) (fc-init userline)) ;(Klaus 30.09.1990) ((eq com 'break) (break)) ((eq com 'style) ; Michael Herfert (rfi-cmd-style userline)) ((eq com 'indexing) (idx.idx-cmd (cdr userline))) ; INDEXING -- real-fun ((or (eq com 'assem) (eq com 'asm)) (gwam.assem-cmd (cdr userline))) ; M. Sintek ((eq com 'undeclare) (setq *rfi-database* (undeclare *rfi-database*))) ; M.S./U.B. ((eq com 'unorf) (cond ((orf2-used) (setq *rfi-database* (orf2 *rfi-database*))) ; U.B. ((orfn-used) (rf-print '|use 'untype' for n-ary ORF|)) (t (rf-print '|ORF not activated|)))) ((eq com 'orf) ; M.S. (if (cadr userline) (if (eq (cadr userline) 'off) (setq *orf* nil) (setq *orf* (cadr userline))) (rf-print (if *orf* *orf* 'off)))) ((eq com 'untype) (set-database (untype (get-database)))) ; M. Sintek ((eq com 'uncomma) (set-database (uncomma (get-database)))) ; M. Sintek ((eq com 'hitrans) (set-database (hotrans (get-database)))) ; M. Sintek ((eq com 'unor) (set-database (unor (get-database)))) ; M. Sintek ((eq com 'unlambda) (set-database (unlambda (get-database)))) ; M. Sintek ((eq com 'unmacro) (set-database (unmacro (get-database)))) ; M. Sintek ((eq com 'passtup) (set-database (passtup (get-database)))) ; M. Christen ((eq com 'sl) (rfi-cmd-style '(style lisp)) ) ((eq com 'sp) (rfi-cmd-style '(style prolog)) ) ((eq com 'sx) (rfi-cmd-style '(style xml)) ) ((member com '(rf2rf rf2rfp rfp2rf rfp2rfp rf2pl rfp2pl bal2bap bap2bal)) (rfi-cmd-translate-file userline) ) ((eq com 'trace) (rfi-cmd-trace userline) ) ((or (eq com 'untrace) (eq com 'notrace)) ; untrace for compatibility (rfi-cmd-untrace userline) ) ; with old batch files only ((eq com 'print-width) (rfi-cmd-print-width userline) ) ((eq com 'miser-level) (rfi-cmd-miser-level userline) ) ((eq com 'consult-sortbase) ;V. Hall (rfi-sortbase-cmd-consult userline)) ((eq com 'complete-taxonomy) (if (eq *sortstyle* 'static) (complete-taxonomy) (rf-error "- running dynamic sort model"))) ((eq com 'unique-glb) (if (eq *sortstyle* 'static) (unique-glb) (rf-error "- running dynamic sort model"))) ((eq com 'unsubsumes) (set-sysbase 'sortbase (unsubsumes (get-sysbase 'sortbase)))) ((eq com 'resubsumes) (set-sysbase 'sortbase (resubsumes (get-sysbase 'sortbase)))) ((eq com 'compile-sortbase) (if (eq *sortstyle* 'static) ( compile-sortbase (get-sysbase 'sortbase)) (rf-error "- running dynamic sort model"))) ((eq com 'sortstyle) (rfi-cmd-sortstyle userline)) ((eq com 'destroy-sortbase) ;V. Hall (setq *subsumes-individuals* nil) (set-sysbase 'sortbase nil)) ((eq com 'sortbase) (when *tcl* (format t "~a{Eval:set listingof sortbase~a}" *esc* *esc*)) (rfi-cmd-l (cadr userline) (get-sysbase 'sortbase))) ((eq com 'browse-sortbase) (if (eq *sortstyle* 'static) (when *tcl* (browse-sortbase (cadr userline))) (rf-error "- running dynamic sort model"))) ((eq com 'load-database) ; only used in RuleGen: (rulegen-load-database userline)) ((eq com 'query) (rulegen-query userline)) ((eq com 'hash) ; [mh] (rfi-cmd-hash userline)) ((eq com 'reconsult) (rfi-cmd-reconsult userline)) ((eq com 'mconsult) ; module system (rfi-cmd-mconsult userline) ) ((eq com 'mreconsult) (rfi-cmd-mreconsult userline) ) ((eq com 'mctx) (rfi-cmd-mctx userline) ) ((eq com 'mctx=) (rfi-cmd-mctx= userline) ) ((eq com 'mcd) (rfi-cmd-mcd userline) ) ((eq com 'mreplace) (rfi-cmd-mreplace userline) ) ((eq com 'mtell) (rfi-cmd-mtell userline) ) ((eq com 'mcreate) (rfi-cmd-mcreate userline) ) ((eq com 'mdestroy) (rfi-cmd-mdestroy userline) ) ((or (eq com 'mlisting) (eq com 'ml)) (rfi-cmd-mlisting userline) ) ((eq com 'minfo) (rfi-cmd-minfo userline) ) ((eq com 'mforest) (rfi-cmd-mforest userline) ) ((eq com 'load) (rfi-cmd-load userline) ) ((eq com 'reload) (rfi-cmd-reload userline) ) ((eq com 'msave) (rfi-cmd-msave userline) ) ((eq com 'map) (rfi-cmd-map userline) ) ((eq com 'mflatten) (rfi-cmd-mflatten userline) ) ((eq com 'mhelp) (rfi-cmd-mhelp userline) ) ) ;; get new input from user afer a interpreter-command (cond ((and (eq com 'bye) (rfi-cmd-bye)) t) (t nil)))) ; ; execute ll command ; (defvar *ll-commands*) (setq *ll-commands* '(ori load assem asm spy nospy emul inter bye)) (defun ll-command-p (userline) (member (car userline) *ll-commands* :test #'equal)) (defun ll-command (userline) (let ((com (car userline))) (cond ((or (eq com 'assem) (eq com 'asm)) (gwam.assem-cmd (cdr userline))) ((eq com 'nospy) (setq *rfi-spy* nil) (setq *emu-debug* nil)) ((eq com 'spy) (setq *rfi-spy* t) (setq *emu-debug* t)) ; interactive? ((eq com 'load) (load-ll-db (cadr userline))) ((eq com 'emul) (setq*style* *rf-style*) (rfi-cmd-emul userline)) ((eq com 'inter) (setq*style* *rf-style*) (rfi-cmd-inter))) (cond ((and (eq com 'bye) (rfi-cmd-bye)) t) (t nil)))) (defun get-database () (if (rfi-interpreter-mode-p) (mod-get-list-of-items *current-module*) *rfi-database* )) (defun set-database (db) (if (rfi-interpreter-mode-p) (mod-set-list-of-items *current-module* db) (setq *rfi-database* db) )) ; --------------------------------------------------------------------------- ; ; syntax style switching and PROLOG-style command handling ; ; --------------------------------------------------------------------------- (defun rfi-cmd-style (userline) (let ((error-p nil) ) (if (= 2 (length userline)) (progn (case (second userline) (lisp (setq *rfi-prompt* (cond ((eq *rfi-machine* 'interpreter) '|rfi-l> |) ((eq *rfi-machine* 'emulator) '|rfe-l> |) (t '|rfc-l> |))) (setq*style* 'lisp) ) (prolog (setq *rfi-prompt* (cond ((eq *rfi-machine* 'interpreter) '|rfi-p> |) ((eq *rfi-machine* 'emulator) '|rfe-p> |) (t '|rfc-p> |))) (setq*style* 'prolog) ) (xml (setq *rfi-prompt* (cond ((eq *rfi-machine* 'interpreter) '|rfi-x> |) ((eq *rfi-machine* 'emulator) '|rfe-x> |) (t '|rfc-x> |))) (setq*style* 'xml) (rf-princ-like-lisp "Notice: Input still style prolog - Output only style xml") ) (t (setq error-p t)) )) (setq error-p t) ) (if error-p (progn (rf-terpri) (rf-princ-like-lisp "Error. Use:") (rf-terpri) (rf-princ-like-lisp " style lisp") (rf-terpri) (rf-princ-like-lisp "or") (rf-terpri) (rf-princ-like-lisp " style prolog") (rf-terpri) (rf-princ-like-lisp "or") (rf-terpri) (rf-princ-like-lisp " style xml") (rf-terpri) )))) (defun setq*style* (style) (setq *style* style) (when *tcl* (format t "~a{Eval:set syntaxmsg ~a ~a}" *esc* style *esc*))) (defun rfi-cmd-translate-file (full-userline-as-list) ;; Called for the following rfi-cmds: ;; rf2rf, rf2rfp, rfp2rf, rfp2rfp (let ((direction (first full-userline-as-list)) (source (second full-userline-as-list)) (destination (third full-userline-as-list)) ) (translate-file source destination :direction direction) )) (defun rfi-cmd-miser-level (userline) (cond ((= 1 (length userline)) (rf-princ-like-lisp *miser-level*) ) ((not (numberp (second userline))) (rf-princ-like-lisp "Error: Number expected.") ) ((member (second userline) '(0 1 2 3)) (setq *miser-level* (second userline)) ) (t (rf-princ-like-lisp "Error: Value out of range.") ))) (defun handle-rfi-cmd (cmd-as-symbol rest-of-line-as-string full-line) "Returns an rfi-command in Lisp-like syntax. Returns NIL if syntax-error." (let ((error-p nil)) (labels ((read-clause () (let ((result (pro-read-clause rest-of-line-as-string))) (setq error-p (null result)) result )) (read-goal () (let ((result (pro-read-goal rest-of-line-as-string))) (setq error-p (null result)) result )) (read-head-functor (&optional (str rest-of-line-as-string)) (let ((result (pro-parse-head-functor str))) (setq error-p (null result)) result )) ) (let ((result (case cmd-as-symbol (a0 (list 'a0 (read-clause))) (az (list 'az (read-clause))) (assert (list 'assert (read-clause))) ((listing l) ;; examples for listing: ;; listing % all clauses ;; listing numbered % functor of head is NUMBERED ;; listing partition[Cr](\|Y) % heads matching the pattern (cond ((string= "" rest-of-line-as-string) '(listing) ) ((position "(" rest-of-line-as-string :test #'string=) (list 'listing (pro-parse-head rest-of-line-as-string) )) (t (cons 'listing (read-goal) )))) (rx (list 'rx (read-clause)) ) (trace (pro-parse-trace-cmd full-line) ) (untrace (pro-parse-trace-cmd full-line) ) ;; 2 RuleGen commands: ((query load-database) (transform-kes-psyn-to-lisp cmd-as-symbol rest-of-line-as-string full-line )) ;; commands not available in P-syntax: ((a0hn a0ft azft azhn) (rf-princ-like-lisp "Command not available in P-syntax.") (setq error-p t) ) ;; no syntax-transformation is needed, when calling ;; these commands: ((builtins break classify codegen compile consult destroy emuc emul endscript exec horizon inter lisp listclass listcode lreplace m miser-level more nospy ori print-width quitwam replace rf sl sp sx script showdepth spy tell verti) (transform-string-to-single-lisp-object full-line) ) ;; other rfi-commands (not listed in the RFM-Manual): (t (transform-string-to-single-lisp-object full-line) )))) (if error-p nil result ))))) (defun rf (silent &rest goals) (tracer-reset-to-zero) ; similarly one might want to reset I/O etc. (let ((*readtable* *rfi-readtable*)) (let ((userline (read-from-string (format nil "~A" goals)))) (let ((res (and-process (deanon-request (if *rfi-static* (flatten-request userline) userline)) '((bottom)) (collect-databases) 1 silent))) (cond ((eq 'tupof silent) res) ((eq 'once silent) (and res (cons (ultimate-instant (un-inst (car res)) (cadr res)) (reverse (answer-bindings (cadr res) nil (cadr res)))))) ((eq 'naf silent) (naf-inversion res))))))) (defun print-bindings (environment) (mapcar #'(lambda (varval) (rf-pprint (list (car varval) '= (mk-inst (de-bnd (cadr varval)))))) (reverse (answer-bindings environment nil environment)))) (defun answer-bindings (environ-left seen-vars environ) (and (cdr environ-left) (let ((variable (caar environ-left))) (cond ((and (null (level-of variable)) (not (member variable seen-vars :test #'equal))) (let ((ultivalue (ultimate-instant variable environ))) (cons (list (variable-name variable) (if (and (bnd-t ultivalue) (equal variable (s-variable-bnd ultivalue))) (s-expr-bnd ultivalue) ultivalue)) (answer-bindings (cdr environ-left) (cons variable seen-vars) environ)))) (t (answer-bindings (cdr environ-left) seen-vars environ)))))) (defun more-p nil "more-p returns nil if the user types `more'. Otherwise it returns the input line." (rf-timer-stop) (do ((response (readl) (readl))) ((or (or (eq (car response) 'm) (eq (car response) 'more)) (eq (car response) 'ori) (eq (car response) 'bye) (not (rfi-command-p response))) (if (or (eq (car response) 'm) (eq (car response) 'more)) (progn (tracer-reset-to-max) (rf-timer-start) nil ) ; signal to and-process to process more answers (progn (tracer-reset-to-zero) response) )) (rfi-command response))) ; ----------------------------------------------------------------------------- ; ; exit to lisp ; ; ----------------------------------------------------------------------------- (defun rfi-cmd-bye () (cond ;((rfi-script-mode-p) ;(rf-error "(rfi-cmd-bye): " "script running!") ;nil) ;((rfi-batch-mode-p) ;(rf-error "(rfi-cmd-bye): " "batchjob running!") ;nil) (t))) (defun rf-error (&rest liste) (rf-print (intern (apply #'concatenate (cons 'string (cons "ERROR " liste))))) (throw :toploop (rf-ignore-errors (readl)))) ; ----------------------------------------------------------------------------- ; ; some useful functions for debugging ; ; ----------------------------------------------------------------------------- ;(defun rs nil ; (setq *readtable* (copy-readtable nil)) ; (princ "The readtable is now restored form standard commonlisp") ; (terpri)) ;(defun lr nil (load "rfi.lisp")) ;;;### eof ;;;### File "speedup.lisp" ; ----------------------------------------------------------------------------- ; ; Speedup -- An indexing mechanism based on hashing for the RELFUN interpreter. ; Michael Herfert, Nov-94. ; Updated Sep-95 to work with procedures distributed over databases. ; ; ----------------------------------------------------------------------------- ;;; Speedup is a simple indexing mechanism to accelerate RELFUN's interpreter. ;;; It uses a hash table to associate two informations with every procedure ;;; (possibly 'distributed'), whose operator is a symbol (the regular case). ;;; The two informations are: ;;; : a list of databases. ;;; The first clause of the first database contains ;;; the first (entry) clause of the procedure. ;;; : a list of clauses with a car containing the ;;; last (exit) clause of the procedure. (defun rfi-cmd-hash (userline) "userline = (hash) userline = (hash on) userline = (hash off) " (cond ((null (cdr userline)) (if *speedup-enable-p* (rf-format "~A hashing is on." (get-comment-lead-in)) (rf-format "~A hashing is off." (get-comment-lead-in)) )) ((eq 'on (second userline)) (setq *speedup-enable-p* t) (rf-format "~A hashing is on now." (get-comment-lead-in)) ) ((eq 'off (second userline)) (setq *speedup-enable-p* nil) (rf-format "~A hashing is off now." (get-comment-lead-in)) ) (t (rf-format "~A hash: use `on' or `off' as argument." (get-comment-lead-in) )))) (defvar *speedup-enable-p* t "<==> use hash tables to accelerate the interpreter. Can be set to NIL for testing purposes.") (defvar *speedup-table* (make-hash-table :size 1000 :rehash-size 1.5 :test #'eq) "For each simple procedure symbol this table records a (entry exit) tuple ( )." ) (defvar *speedup-copy* nil "Copy of RELFUN's databases (containing pointers to subdatabases). If any the subdatabases will not be eq to its original, the *speedup-table* must be reinitialized." ) (defun speedup-hash (operator) "Returns a tuple ( ). Returns nil if hashing has failed." (when *speedup-enable-p* ;;(format t "hashing for ~A~%" operator) (if (symbolp operator) (gethash operator *speedup-table*) ;; an extension to handle non-atomic operators is possible, ;; but not implemented. nil ))) (defun speedup-init () "Initialize the hash table used for indexing." ;;(princ "Initializing hash table.") (clrhash *speedup-table*) (setq *speedup-copy* (collect-databases)) (unless (some #'vari-t (operators)) ;; Indexing is enabled only if the database has no clauses with ;; variables as operators. (mapl #'(lambda (databases) (do* ((rest-db (first databases) (cdr rest-db)) (clause (car rest-db) (car rest-db)) (operator (caadr clause) (caadr clause)) ) ((null rest-db)) (when (symbolp operator) (let ((entry (gethash operator *speedup-table*))) (if entry (setf (cadr entry) rest-db) ; assume last clause ;; first occurence of operator: (setf (gethash operator *speedup-table*) (list (cons rest-db (cdr databases)) rest-db ))))))) *speedup-copy* ))) (defun speedup-check () "Re-initializes the hash table used for indexing, if there was some update (e.g. az, rx) on any subdatabase." (when (or (/= (length (collect-databases)) ; alternatively, the (length *speedup-copy*) ) ; commands az, rx, etc. (notevery #'eq ; could maintain a (collect-databases) ; global 'update' *speedup-copy*)) ; variable (speedup-init) )) #+rf-ez-list (defun speedup-print (&optional (compact-p t)) "Prints the hash table used for indexing by the interpreter. If parameter COMPACT-P is nil,the table is printed like its internal format. If parameter COMPACT-P is t, only the entry and the exit clauses are printed to save space." (let (assoc-list ) (maphash #'(lambda (key value) (setq assoc-list (cons (cons (string key) value) assoc-list))) *speedup-table* ) (sort assoc-list #'string< :key #'car) ; destructively (rf-format "The hash table has ~a entries.~%~%" (hash-table-count *speedup-table*) ) (dolist (key-value-pair assoc-list) (if compact-p (progn (rf-format "~a: (entry)~%" (get-el (key . "value") key-value-pair)) (rf-pprint (get-el ("key" . (((entry-clause . "rest-clauses") . "rest-dbs") "exit")) key-value-pair )) (rf-format "~a: (exit)~%" (get-el (key . "value") key-value-pair)) (rf-pprint (get-el ("key" . ("entry" (exit-clause . "rest-db"))) key-value-pair ))) (progn (rf-format "~a: (entry)~%" (get-el (key . "value") key-value-pair)) (rf-pprint-db (get-el ("key" . (entry "exit")) key-value-pair )) (rf-format "~a: (exit)~%" (get-el (key . "value") key-value-pair)) (rf-pprint-db (get-el ("key" . ("entry" exit)) key-value-pair ))))))) (defmacro speedup-and (original-code) "This macro is called once, at the end of and-process: It has the last call of or-process as argument." ` (let ((entry-exit (speedup-hash (car term)))) (if entry-exit ;; jump immediately to the first clause of the procedure, ;; whithout testing all preceding database entries: (or-process (caar entry-exit) ; database starting with first clause (cdar entry-exit) ; procedure may continue in other dbs database (cdr list-of-terms) term environment environment ; current env as backup for sg level silent ) ,original-code ; no indexing information found ))) (defmacro speedup-or (original-code) "This macro is called once, at the end of or-process: It has the recursive call of or-process as argument." ` (let ((entry-exit (speedup-hash (car goal)))) (if entry-exit (if (eq db-left (second entry-exit)) ;; do not search through the rest of the database, ;; because there are no more clauses of this procedure available: nil ,original-code ) ,original-code ))) ;;;### eof ;;;### File "andor.lisp" (defun and-process (list-of-terms environment database level silent) ; ; tracing ; (if *rfi-spy* (rf-pprint-spy (cons (cond ((not silent) 'and) ((eq 'tupof silent) 'tund) ((eq 'once silent) '1and) ((eq 'naf silent) 'nand)) (mapcar #'(lambda (g) (ultimate-inst-instant g environment t)) list-of-terms)))) ; ; extract next term ; (let ((term (cond (list-of-terms (ultimate-opis-assoc (car list-of-terms) environment)) ; built-ins may be bound to log. variables (is,ecal,lisp-builtin) (t 'true)))) ; ; select next and-operation ; (cond ; ; is term unknown? ; or ; is right side of is-term unknown? ; ((eq 'unknown (un-is term)) nil) ; ; no more terms left? ; or ; is term final and no more other terms are left? ; ((or (null list-of-terms) (and (null (cdr list-of-terms)) (final-p term))) (cond ((eq 'tupof silent) (list (ultimate-instant (un-inst term) environment))) ((eq 'once silent) (list term environment level)) ((eq 'naf silent) (ultimate-assoc term environment)) (t (let ((globenvir (globalize (un-inst term) environment))) (cond (globenvir (rf-pprint (mk-inst (de-bnd (ultimate-instant (un-inst term) globenvir)))) (print-bindings globenvir) (more-p)) (t (rf-pprint 'unknown) (more-p))))))) ; ; is term false? ; ((eq 'false term) nil) ; ; is term final? ; ((final-p term) (and-process (cdr list-of-terms) environment database level silent)) ; ; is right side of is final? ; ((final-is-p term) (let ((is-environment (unify (s-patt-is term) (un-inst (s-expr-is term)) environment))) (and is-environment (and-process (or (cdr list-of-terms) (cons (mk-inst (s-patt-is term)) nil)) is-environment database level silent)))) ; ; tupof:all solutions, once:first solution, naf:negation as failure ; ((tupof-t (un-is term)) (let ((list-of-val (and-process (ultimate-inst-instant (s-conj-tupof (un-is term)) environment t) environment database level 'tupof))) ; (and list-of-val (and-process (cons (gen-is term (mkk-inst (cons 'tup list-of-val))) (cdr list-of-terms)) environment database level silent) ; ) )) ((once-t (un-is term)) (let ((val-env-lev (and-process (ultimate-inst-instant (s-conj-once (un-is term)) environment t) environment database level 'once))) (and val-env-lev (and-process (cons (gen-is term (car val-env-lev)) (cdr list-of-terms)) (cadr val-env-lev) database (caddr val-env-lev) silent)))) ((naf-t (un-is term)) (let ((uiiconj (ultimate-inst-instant (s-conj-naf (un-is term)) environment t))) (cond ((not (naf-ground-p uiiconj)) (rf-error "(naf): " (format nil "~A" uiiconj) " non-ground argument")) (t (and (naf-inversion (and-process uiiconj '((bottom)) database level 'naf)) (and-process (cons (gen-is term 'true) (cdr list-of-terms)) environment database level silent)))))) ; Hack by M. Sintek: ((typed-expr-t (un-is term)) ; (expr1 : expr2) -> (mgu expr1 expr2) (and-process (cons (gen-is term (list 'mgu (typed-expr-term (un-is term)) (typed-expr-type (un-is term)))) (cdr list-of-terms)) environment database level silent)) ; ; call and-process, lisp or or-process ; (t (let ((conjunction-goal (if *rfi-static* '(nil) (dynamic-flattener (un-is term) 1 level)))) (cond ((car conjunction-goal) (and-process (append (car conjunction-goal) (cons (gen-is term (cadr conjunction-goal)) (cdr list-of-terms))) environment database (+ level 1) silent)) ; ; meta-call? ; ((ecal-t (un-is term)) (and-process (cons (gen-is term (ultimate-assoc (un-inst (cadr (un-is term))) environment)) (cdr list-of-terms)) environment database level silent)) ; ; normalize active dom and exc ; ((dom-t (un-is term)) (and-process (cons (gen-is term (let ((resdom (mk-dom (remove-duplicates (cdr (ultimate-instant (de-inst (un-is term)) environment)))))) (if resdom (mkk-inst (mk-bnd (list 'vari (gensym "anon") level) resdom)) 'unknown))) (cdr list-of-terms)) environment database (+ level 1) ; increment not (longer) needed for 'unknown silent)) ((exc-t (un-is term)) (and-process (cons (gen-is term (mkk-inst (mk-bnd (list 'vari (gensym "anon") level) (mk-exc (remove-duplicates (cdr (ultimate-instant (de-inst (un-is term)) environment))))))) (cdr list-of-terms)) environment database (+ level 1) silent)) ; ; dynamic assert and retract ; ((eq 'assertz (car (un-is term))) (and-process (cons (gen-is term (assertz (cadr (un-is term)) environment)) ; call az etc. (cdr list-of-terms)) environment (collect-databases) ; fetch az-changed copy level silent)) ((eq 'retractx (car (un-is term))) (and-process (cons (gen-is term (retractx (cadr (un-is term)) environment)) ; call rx etc. (cdr list-of-terms)) environment (collect-databases) ; fetch rx-changed copy level silent)) ; ; call lisp? ; ((relfun-builtin-p (car (un-is term))) ;(Klaus 30.09.1990) (and-process (cons (gen-is term (relfun-exec (un-is term) environment)) (cdr list-of-terms)) environment database level silent)) ((lisp-builtin-p (car (un-is term))) (let ((globenvir (globalize (un-is term) environment))) (and globenvir (and-process (cons (gen-is term (lisp-exec (un-is term) globenvir)) (cdr list-of-terms)) globenvir database level silent)))) (t (speedup-and (or-process (s-first-db database) (s-rest-db database) database (cdr list-of-terms) term environment environment ; current env as backup for sg level silent))))))))) (defun or-process (db-left db-right database terms-left goal environment orig-env level silent) (cond ((and (null db-left) (null db-right)) nil) ((null db-left) (or-process (s-first-db db-right) (s-rest-db db-right) database terms-left goal environment orig-env level silent)) ;; ;; dynamic signature testing ;; ((and (equal (s-kind (car db-left)) 'sg) (unify (car (s-head (car db-left))) (car (de-inst (un-is goal))) orig-env)) ; sg-clause for goal (let ((new-environment (unify (de-inst (un-is goal)) (ren-var nil (s-head (car db-left)) (list level)) orig-env))) (if new-environment (or-process (cdr db-left) ; goal passes sg-check db-right database terms-left goal new-environment orig-env (+ level 1) silent) ; goal fails at sg -> jump to next sg (or-process (jump-to-next-sg (cdr db-left) (de-inst (un-is goal)) orig-env) db-right database terms-left goal orig-env orig-env level silent)))) (t (let ((new-environment (cond ((clause-t (un-is goal)) (unify (de-inst (s-clause (un-is goal))) (rename-variables (car db-left) (list level)) environment)) (t (unify (de-inst (un-is goal)) (ren-var nil (s-conclusion (car db-left)) (list level)) environment))))) (cond ((null new-environment) (or-process (cdr db-left) db-right database terms-left goal environment orig-env level silent)) (t (let* ((premises (cond ((clause-t (un-is goal)) (list (mkk-inst (car db-left)))) (t (s-premises (car db-left))))) (cutail (member '! premises))) (cond (cutail (let ((guards (ldiff premises cutail))) (cond ((null guards) (and-process (append-is goal (car db-left) (ren-var t (cdr cutail) (list level)) terms-left) new-environment database (1+ level) silent)) (t (let ((val-env-lev (and-process (append-guards (cdr cutail) (car db-left) (ren-var t guards (list level))) new-environment database (1+ level) 'once))) (cond (val-env-lev (and-process (append-is goal (car db-left) (cons (car val-env-lev) (ren-var t (cdr cutail) (list level))) terms-left) (cadr val-env-lev) database (caddr val-env-lev) silent)) (t (or-process (cdr db-left) db-right database terms-left goal environment orig-env level silent)))))))) ((eq 'tupof silent) (append (and-process (append-is goal (car db-left) (ren-var t premises (list level)) terms-left) new-environment database (1+ level) silent) (or-process (cdr db-left) db-right database terms-left goal environment orig-env level silent))) (t (or (and-process (append-is goal (car db-left) (ren-var t premises (list level)) terms-left) new-environment database (1+ level) silent) (speedup-or (or-process (cdr db-left) db-right database terms-left goal environment orig-env level silent)))))))))))) (defun jump-to-next-sg (db-left term env) ;; jumps to next signature of the same procedure in the actual module/SA (cond ((null db-left) nil) ((and (equal (s-kind (car db-left)) 'sg) ; tag (unify (car (s-head (car db-left))) (car term) env)) ; operator db-left) (t (jump-to-next-sg (cdr db-left) term env)))) (defun dynamic-flattener (term varnum level) (cond ((final-p term) (list nil term)) ((is-tt term) (list (cons term nil) (mk-inst (s-patt-is term)))) ; ((ecal-t term) ; (let ((varstruct (legnumvar (list varnum level)))) ; (list (cons (mk-is varstruct term) ; nil) ; varstruct))) ((final-p (car term)) (let ((conjunction-goal (dynamic-flattener (cdr term) varnum level))) (list (car conjunction-goal) (cons (car term) (cadr conjunction-goal))))) (t (let ((varstruct (legnumvar (list varnum level))) (conjunction-goal (dynamic-flattener (cdr term) (+ varnum 1) level))) (list (cons (mk-is varstruct (car term)) (car conjunction-goal)) (cons varstruct (cadr conjunction-goal))))))) (defun append-guards (tail assertion guards) (cond ((and (ft-t assertion) (null tail)) guards) (t (append guards '(true))))) (defun append-is (goal assertion prefix suffix) (cond ((is-t goal) (cond ((and (not (clause-t (un-is goal))) (hn-t assertion)) (append prefix (cons (mk-is (s-patt-is goal) 'true) suffix))) ; ((ft-t assertion) (append-patt (s-patt-is goal) ; prefix ; suffix)) (t (append-patt (s-patt-is goal) prefix suffix)))) ; (t (rf-error "(append-is): undefined clause type")))) ((and (not (clause-t goal)) (hn-t assertion) (null suffix)) (append prefix '(true))) (t (append prefix suffix)))) (defun append-patt (patt prefix suffix) (cond ((null prefix) (rf-error "(append-patt): missing foot")) ((null (cdr prefix)) (cons (mk-is patt (car prefix)) suffix)) (t (cons (car prefix) (append-patt patt (cdr prefix) suffix))))) ;;;### eof ;;;### File "unifult.lisp" ; Hack a la active ":" in and-process: (defun typed-expr2bnd (term) ; (expr1 : expr2) -> (bnd expr1 expr2) (cond ((typed-expr-t term) (mk-bnd (typed-expr-term term) (typed-expr-type term))) (t term))) (defun unify (x y environment) (let ((x (typed-expr2bnd (ultimate-assoc x environment))) ; typed-expr2bnd (y (typed-expr2bnd (ultimate-assoc y environment)))) ; see above ; (let ((x (ultimate-assoc x environment)) ; (y (ultimate-assoc y environment))) (cond ((and (or (atom x) (vari-t x)) (equal x y)) environment) ((or (bnd-t x) (bnd-t y)) (unify-bnd (un-bnd x) (un-bnd y) (variable-if-bnd x) (variable-if-bnd y) environment)) ((or (anonymous-p x) (anonymous-p y)) environment) ((vari-t x) (cons (list x y) environment)) ((vari-t y) (cons (list y x) environment)) ; Since deanon embeds dom, exc, and typ terms into bnd's, ; the following cases are normally treated in unify-bnd; ; this unify-bnd overlap part could be omitted if all calls ; to unify (also e.g. in listing) were initialized by deanon ... ((and (dom-t x) (exc-t y)) (and (dom-exc x y) environment)) ((and (exc-t x) (dom-t y)) (and (dom-exc y x) environment)) ((and (dom-t x) (dom-t y)) (and (dom-intersection x y) environment)) ((and (exc-t x) (exc-t y)) environment) ((and (dom-t x) (typ-t y)) (if (buisob-sortp (s-type y)) (and (dom-in-buisort x (s-type y)) ; builtin-sort environment) (and (dom-in-sort x (s-type y)) ; user-defined sort environment))) ((and (typ-t x) (dom-t y)) (if (buisob-sortp (s-type x)) (and (dom-in-buisort y (s-type x)) ; builtin-sort environment) (and (dom-in-sort y (s-type x)) ; user-defined sort environment))) ((and (exc-t x) (typ-t y)) (let ((y-ext (ub-sortbase-ind (s-type y)))) (if y-ext (dom-exc y-ext x) ; user-defined sort (rf-error "(unify): GLB is not computable between exclusion and builtin-sort")))) ; builtin-sort ((and (typ-t x) (exc-t y)) (let ((x-ext (ub-sortbase-ind (s-type x)))) (if x-ext (dom-exc x-ext y) ; user-defined sort (rf-error "(unify): GLB is not computable between builtin-sort and exclusion")))) ; builtin-sort ((dom-t x) (and (member y (cdr x) :test #'equal) environment)) ((dom-t y) (and (member x (cdr y) :test #'equal) environment)) ((exc-t x) (and (not (member y (cdr x) :test #'equal)) environment)) ((exc-t y) (and (not (member x (cdr y) :test #'equal)) environment)) ((and (typ-t x) (atom y)) (and (ub-sortbase-individualsp y (s-type x)) environment)) ((and (atom x) (typ-t y)) (and (ub-sortbase-individualsp x (s-type y)) environment)) ((and (typ-t x) (typ-t y)) (and (ub-sortbase-glb (s-type x) (s-type y)) environment)) ; ... end of unify-bnd overlap part. ((or (atom x) (atom y)) nil) (t (let ((new-environment (unify (car x) (car y) environment))) (and new-environment (unify-args (cdr x) (cdr y) new-environment))))))) (defun unify-args (x y environment) ;------------ throw out if and when dot unification becomes forbidden --------- ; (let ((x (ultimate-assoc x environment)) ; (y (ultimate-assoc y environment))) ;------------------------------------------------------------------------------ (cond ((and (null x) (null y)) environment) ;------------ throw out if and when dot unification becomes forbidden --------- ; ((or (anonymous-p x) ; (anonymous-p y)) ; environment) ; ((vari-t x) (cons (list x y) environment)) ; ((vari-t y) (cons (list y x) environment)) ;------------------------------------------------------------------------------ ((and (bar-t x) (bar-t y)) ; both cadr's should exist (unify (cadr x) (cadr y) environment)) ; both cddr's should be nil ((bar-t x) ; cadr of x should exist (unify (cadr x) (cons 'tup y) environment)) ; its cddr should be nil ((bar-t y) ; cadr of y should exist (unify (cons 'tup x) (cadr y) environment)) ; its cddr should be nil ((or (null x) (null y)) nil) ;------------ throw out if and when dot unification becomes forbidden --------- ; ((or (atom x) (atom y)) nil) ;------------------------------------------------------------------------------ (t (let ((new-environment (unify (car x) (car y) environment))) (and new-environment (unify-args (cdr x) (cdr y) new-environment))))) ;------------ throw out if and when dot unification becomes forbidden --------- ;) ;------------------------------------------------------------------------------ ) (defun unify-bnd (x y xvar yvar environment) (cond ((and (dom-t x) (exc-t y)) (let ((differ (dom-exc x y))) (and differ (unify-bnd-env differ xvar yvar environment)))) ((and (exc-t x) (dom-t y)) (let ((differ (dom-exc y x))) (and differ (unify-bnd-env differ xvar yvar environment)))) ((and (dom-t x) (dom-t y)) (let ((inter (dom-intersection x y))) (and inter (unify-bnd-env inter xvar yvar environment)))) ((and (exc-t x) (exc-t y)) (unify-bnd-env (exc-union x y) xvar yvar environment)) ((and (typ-t x) (dom-t y)) (if (buisob-sortp (s-type x)) (let ((sort-dom (dom-in-buisort y (s-type x)))) (and sort-dom (unify-bnd-env sort-dom xvar yvar environment))) (let ((sort-dom (dom-in-sort y (s-type x)))) (and sort-dom (unify-bnd-env sort-dom xvar yvar environment))))) ((and (dom-t x) (typ-t y)) (if (buisob-sortp (s-type y)) (let ((sort-dom (dom-in-buisort x (s-type y)))) (and sort-dom (unify-bnd-env sort-dom xvar yvar environment))) (let ((sort-dom (dom-in-sort x (s-type y)))) (and sort-dom (unify-bnd-env sort-dom xvar yvar environment))))) ((and (typ-t x) (exc-t y)) (let ((x-ext (ub-sortbase-ind (s-type x)))) (if x-ext (dom-exc x-ext y) ; user-defined sort (rf-error "(unify): GLB is not computable between builtin-sort and exclusion")))) ; builtin-sort ((and (exc-t x) (typ-t y)) (let ((y-ext (ub-sortbase-ind (s-type y)))) (if y-ext (dom-exc y-ext x) ; user-defined sort (rf-error "(unify): GLB is not computable between exclusion and builtin-sort")))) ; builtin-sort ((and (dom-t x) (typexcdom-elem y)) (and (member y (cdr x) :test #'equal) (unify-bnd-env y xvar yvar environment))) ((and (dom-t y) (typexcdom-elem x)) (and (member x (cdr y) :test #'equal) (unify-bnd-env x xvar yvar environment))) ((and (exc-t x) (typexcdom-elem y)) (and (not (member y (cdr x) :test #'equal)) (unify-bnd-env y xvar yvar environment))) ((and (exc-t y) (typexcdom-elem x)) (and (not (member x (cdr y) :test #'equal)) (unify-bnd-env x xvar yvar environment))) ((and (typ-t x) (typ-t y)) (let ((sort-sort (ub-sortbase-glb (s-type x) (s-type y)))) (and sort-sort (unify-bnd-env sort-sort xvar yvar environment)))) ((and (typ-t x) (typexcdom-elem y)) (and (ub-sortbase-individualsp y (s-type x)) (unify-bnd-env y xvar yvar environment))) ((and (typ-t y) (typexcdom-elem x)) (and (ub-sortbase-individualsp x (s-type y)) (unify-bnd-env x xvar yvar environment))) (t (let ((new (unify x y environment))) (and new (unify-bnd-env (if (vari-t x) x y) xvar yvar new)))) )) (defun typexcdom-elem (term) (atom term)) ; (not (vari-t term)) included embedded bnd-t's (defun unify-bnd-env (val xvar yvar environment) (cond ((and xvar yvar) ; append prevents binding loops (cond ((and (varivari-t xvar) (varivari-t yvar)) ;both vars coded (append (and (not (equal (cadr xvar) (cadr yvar))) ;from ulti- (list (list (cadr xvar) (cadr yvar)))) ;mate-assoc (cons (list (cadr yvar) val) environment))) ;-> chain 2 ((varivari-t yvar) ;decodings (let ((pattval (unify xvar val environment))) (and pattval (append (and (not (equal (cadr yvar) xvar)) (list (list (cadr yvar) xvar))) pattval)))) ((varivari-t xvar) (let ((pattval (unify yvar val environment))) (and pattval (append (and (not (equal (cadr xvar) yvar)) (list (list (cadr xvar) yvar))) pattval)))) (t (let ((pattpatt (unify xvar yvar environment))) (and pattpatt (unify yvar val pattpatt)))))) (xvar (cond ((varivari-t xvar) (cons (list (cadr xvar) val) environment)) (t (unify xvar val environment)))) (yvar (cond ((varivari-t yvar) (cons (list (cadr yvar) val) environment)) (t (unify yvar val environment)))))) (defun dom-intersection (x y) (mk-dom (intersection (cdr x) (cdr y) :test #'equal))) (defun exc-union (x y) (mk-exc (union (cdr x) (cdr y) :test #'equal))) (defun dom-exc (x y) (mk-dom (set-difference (cdr x) (cdr y) :test #'equal))) (defun dom-in-sort (dom sort) (if (eq *sortstyle* 'static) (dom-intersection dom (sortbase-ind sort)) (and dom (mk-dom (remove nil (const-list-in-sort (cdr dom) sort)))))) (defun const-list-in-sort (const_list sort) (cond ((null const_list) nil) (t (cons (const-in-sort (car const_list) sort) (const-list-in-sort (cdr const_list) sort))))) (defun const-in-sort (const sort) (let ((res (and-process (list (list 'constant-in-sort const sort)) '((bottom)) (collect-databases) 1 'once))) (ultimate-instant (un-inst (car res)) (cadr res)))) ;The function sort-intersection returns the first glb found, i.e. (cadr ...); ;The RELFUN function `greatest-lower-bound' called here ;returns a list of all `glbs': (defun sort-intersection (sort1 sort2) (let ((res (and-process (list (list 'greatest-lower-bound sort1 sort2)) '((bottom)) (collect-databases) 1 'once))) (cadr (ultimate-instant (un-inst (car res)) (cadr res))))) (defun ultimate-assoc (x environment) (cond ((vari-t x) ; (list 'vari x) decoded in (let ((binding (assoc x environment :test #'equal))) ; unify-bnd-env (cond ((null binding) x) ((typexcdom-p (cadr binding)) (mk-bnd (list 'vari x) (cadr binding))) (t (ultimate-assoc (cadr binding) environment))))) (t x))) (defun globalize (x environment) (cond ((atom x) environment) ((bnd-t x) (unify (s-variable-bnd x) (s-expr-bnd x) environment)) ((vari-t x) (let ((binding (ultimate-assoc x environment))) (cond ((vari-t binding) environment) ((and (bnd-t binding) (varivari-t (s-variable-bnd binding))) environment) (t (globalize binding environment))))) (t (let ((new-environment (globalize (car x) environment))) (and new-environment (globalize (cdr x) new-environment)))))) (defun ultimate-instant (x environment) (cond ((bnd-t x) (cond ;((and (vari-t (s-variable-bnd x)) ; (typexcdom-p (s-expr-bnd x))) x) ; also for "id"/"_" ? (t (ultimate-instant (s-variable-bnd x) environment)))) ((vari-t x) (let ((binding (ultimate-assoc x environment))) (cond ((vari-t binding) binding) ((and (bnd-t binding) (varivari-t (s-variable-bnd binding))) (mk-bnd (cadr (s-variable-bnd binding)) (s-expr-bnd binding))) (t (ultimate-instant binding environment))))) ; (let ((binding (assoc x environment :test #'equal))) ; (cond ((null binding) x) ; (t (ultimate-instant (cadr binding) ; environment))))) ((atom x) x) ((bar-t x) ; (cddr x) should be nil (let ((barinst (ultimate-instant (cadr x) environment))) (cond ((tup-t barinst) (cdr barinst)) (t (list (car x) barinst))))) ; (car x) is "|" (t (cons (ultimate-instant (car x) environment) (ultimate-instant (cdr x) environment))))) (defun ultimate-opis-assoc (x environment) (cond ((or (final-p x) (and (not (vari-t (car x))) (not (eq 'is (car x))))) x) (t (let ((opassoc (ultimate-assoc (car x) environment))) (cond ((eq 'is opassoc) (mk-is (cadr x) (cond ((or (final-p (caddr x)) (not (vari-t (car (caddr x))))) (caddr x)) (t (cons (mk-inst (ultimate-assoc (car (caddr x)) environment)) (cdr (caddr x))))))) (t (cons (mk-inst opassoc) (cdr x)))))))) (defun ultimate-inst-instant ; no special bnd treatment (x environment showinst) (cond ((vari-t x) (let ((binding (assoc x environment :test #'equal))) (cond ((null binding) x) (t (cond (showinst (mk-inst (ultimate-inst-instant (cadr binding) environment nil))) (t (ultimate-inst-instant (cadr binding) environment nil))))))) ((atom x) x) ((inst-t x) (mk-inst (ultimate-inst-instant (un-inst x) environment nil))) ((bar-t x) ; (cddr x) should be nil (let ((barinst (ultimate-inst-instant (cadr x) environment showinst))) (cond ((and showinst (inst-t barinst) (tup-t (un-inst barinst))) (mapcar #'mk-inst (cdr (un-inst barinst)))) ((and (not showinst) (tup-t barinst)) (cdr barinst)) (t (list (car x) barinst))))) ; (car x) is "|" ((is-tt x) (mk-is (ultimate-inst-instant (s-patt-is x) environment nil) (ultimate-inst-instant (s-expr-is x) environment showinst))) (t (cons (ultimate-inst-instant (car x) environment showinst) (ultimate-inst-instant (cdr x) environment showinst))))) (defun rename-variables (clause listified-level) (cons (s-kind clause) (cons (ren-var nil (s-head clause) listified-level) ; passive context (ren-var t (s-premises clause) listified-level)))) ; active context (defun ren-var (activenv term listified-level) (cond ((anonymous-p term) (cons 'vari (cons (gensym "anon") listified-level))) ((bnd-t term) (cond ((and (typexcdom-p (s-variable-bnd term)) (typexcdom-p (s-expr-bnd term))) (mk-bnd (mk-bnd (cons 'vari (cons (gensym "anon") listified-level)) (s-variable-bnd term)) (s-expr-bnd term))) ((typexcdom-p (s-variable-bnd term)) (mk-bnd (s-variable-bnd term) (ren-var activenv (s-expr-bnd term) listified-level))) ((typexcdom-p (s-expr-bnd term)) (mk-bnd (ren-var activenv (s-variable-bnd term) listified-level) (s-expr-bnd term))) (t (mk-bnd (ren-var activenv (s-variable-bnd term) listified-level) (ren-var activenv (s-expr-bnd term) listified-level))))) ((typexcdom-p term) (cond ((and activenv (typ-t term)) (mkk-inst (mk-bnd (cons 'vari (cons (gensym "anon") listified-level)) term))) (activenv term) (t (mk-bnd (cons 'vari (cons (gensym "anon") listified-level)) term)))) ((vari-t term) (append term listified-level)) ((atom term) term) ((inst-t term) (mkk-inst (ren-var nil (cadr term) listified-level))) ((is-tt term) (mk-is (ren-var nil (s-patt-is term) listified-level) (cond ((and (vari-t (s-patt-is term)) (typexcdom-p (un-inst (s-expr-is term)))) (s-expr-is term)) (t (ren-var activenv (s-expr-is term) listified-level))))) (t (cons (ren-var activenv (car term) listified-level) (ren-var activenv (cdr term) listified-level))))) ;;;### eof ;;;### File "buisob.lisp" ; ub-sortbase: sortbase + buisob (User-defined and Builtin sortbase) ; ------------------------------------------------------------------ (defun ub-sortbase-sortp (sort) (or (buisob-sortp sort) (sortbase-sortp sort))) (defun ub-sortbase-individualsp (const sort) (if (buisob-sortp sort) (buisob-individualsp const sort) (sortbase-individualsp const sort))) (defun ub-sortbase-ind (sort) (unless (buisob-sortp sort) (sortbase-ind sort))) (defun ub-sortbase-glb (sort1 sort2) (if (buisob-sortp sort1) (if (buisob-sortp sort2) (mk-type (buisob-glb sort1 sort2)) (buisob-sortbase-glb-inter sort1 sort2)) (if (buisob-sortp sort2) (buisob-sortbase-glb-inter sort2 sort1) (mk-type (sortbase-glb sort1 sort2))))) (defun buisob-sortbase-glb-inter (buisob-sort sortbase-sort) (mk-dom (remove-if-not #'(lambda (x) (buisob-individualsp x buisob-sort)) (cdr (sortbase-ind sortbase-sort))))) ; buisob: builtin sortbase ; ------------------------ (defvar *buisob*) ; *buisob* = (sort1 sort2 .. sortN) ; sortI = (name function subsumes*) (setq *buisob* ; indenting shows sort hierarchy `((atom ,#'atom (atom symbolp stringp numberp floatp integerp evenp oddp)) (symbolp ,#'symbolp (symbolp)) (stringp ,#'stringp (stringp)) (numberp ,#'numberp (numberp floatp integerp evenp oddp)) (floatp ,#'floatp (floatp)) (integerp ,#'integerp (integerp evenp oddp)) (evenp ,#'(lambda (x) (and (integerp x) (evenp x))) (evenp)) (oddp ,#'(lambda (x) (and (integerp x) (oddp x))) (oddp)))) (defun buisob-sortp (sort) (assoc sort *buisob*)) (defun buisob-glb (sort1 sort2) (glb (caddr (assoc sort1 *buisob*)) (caddr (assoc sort2 *buisob*)))) (defun buisob-individualsp (const sort) (funcall (cadr (assoc sort *buisob*)) const)) (defun dom-in-buisort (dom buisob-sort) (mk-dom (remove-if-not #'(lambda (x) (buisob-individualsp x buisob-sort)) (cdr dom)))) ;;;### eof ;;;### File "sortoper.lisp" ; check if sort is defined (occurs) in the *subsumes-individuals* list: (defun sortbase-sortp (sort) (sort-defined sort *subsumes-individuals*)) (defun sort-defined (sort list) (and list (cond ((equal sort (caar list)) t) (t (sort-defined sort (cdr list)))))) ; check if individual is in sort: (defun sortbase-individualsp (const sort) (if (eq *sortstyle* 'static) (cond ((member const (get-ind*-list (get-sort-list *subsumes-individuals* sort)) ) const) (t nil)) (const-in-sort const sort))) (defun sortbase-ind (sort) (and (sortbase-sortp sort) (let ((ind*-list (get-ind*-list (get-sort-list *subsumes-individuals* sort)))) (cond (ind*-list (cons 'dom (cdr ind*-list))) (t nil))))) ; intersect two sorts: (defun sortbase-glb (sort1 sort2) (if (eq *sortstyle* 'static) (sortbase-glb1 sort1 sort2) (sort-intersection sort1 sort2))) (defun sortbase-glb1 (sort1 sort2) (let ((subsumes1 (cdr (get-sub*-list (get-sort-list *subsumes-individuals* sort1)))) (subsumes2 (cdr (get-sub*-list (get-sort-list *subsumes-individuals* sort2))))) (glb subsumes1 subsumes2))) (defun glb (sub-list1 sub-list2) (and sub-list1 (cond ((member (car sub-list1) sub-list2) (car sub-list1)) (t (glb (cdr sub-list1) sub-list2))))) ;************************************************************************ ; sortbase functions for the browser ;************************************************************************ (defun sortbase-top (root) ; returns a list of top sorts (if root (list root) (let ((all-sorts (mapcar #'car *subsumes-individuals*)) (child-sorts (mapcan #'(lambda (s) (copy-list (cdadr s))) *subsumes-individuals*))) (set-difference all-sorts child-sorts)))) (defun sortbase-children (x) (if (listp x) (cdadr (assoc (car x) *subsumes-individuals* :test #'equal)) (cdadr (assoc x *subsumes-individuals* :test #'equal)))) (defun sortbase-individuals*-string (sort-string) (let ((*print-case* :downcase)) (format nil "~a: ~a" sort-string (list-to-message (cdr (fifth (assoc (read-from-string sort-string) *subsumes-individuals*))))))) (defun list-to-message (l) (cond ((null l) "") ((null (cdr l)) (format nil "~a" (car l))) (t (format nil "~a, ~a" (car l) (list-to-message (cdr l)))))) ;;;### eof ;;;### File "sortsubind.lisp" (defun rfi-cmd-sortstyle (userline) (let ((error-p nil) ) (cond ((= 2 (length userline)) (cond ((eq (second userline) 'static) (setq *sortstyle* 'static)) ((eq (second userline) 'dynamic) (setq *sortstyle* 'dynamic)) (t (setq error-p t)))) ((= 1 (length userline)) (rf-print *sortstyle*)) (t (setq error-p t))) (if error-p (progn (rf-terpri) (rf-princ-like-lisp "Error. Use:") (rf-terpri) (rf-princ-like-lisp " sortstyle static") (rf-terpri) (rf-princ-like-lisp "or") (rf-terpri) (rf-princ-like-lisp " sortstyle dynamic") (rf-terpri) (rf-princ-like-lisp "or") (rf-terpri) (rf-princ-like-lisp " sortstyle") (rf-terpri))))) (defun rfi-sortbase-cmd-consult (userline) (let* ((filename (rfi-extension (cadr userline) (rf-or-rfp)))) (if (probe-file filename) (set-sysbase 'sortbase (append (get-sysbase 'sortbase) (rfi-cmd-consult-1 filename))) (rf-error "(rfi-sortbase-cmd-consult): " filename " file doesn't exist!")))) ;* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * (defun all-sorts (sub-ind-list) ; select sorts from a subsumes-individuals list (mapcar #'(lambda (sort-list) (car sort-list)) sub-ind-list)) (defun combine-all-sorts (list1 list2) ; pair two lists (cond ((null list1) nil) ((null list2) (combine-all-sorts (cdr list1) (cddr list1))) (t (cons (list (car list1) (car list2)) (combine-all-sorts list1 (cdr list2)))))) ;************************************************************************** ; Check the taxonomy for completeness (intensional glb = extensional glb) ;************************************************************************** (defun complete-taxonomy () (complete-taxonomy1 (combine-all-sorts (all-sorts *subsumes-individuals*) (cdr (all-sorts *subsumes-individuals*))))) (defun complete-taxonomy1 (comb-sort-list) (if comb-sort-list (let ((sort1 (caar comb-sort-list)) (sort2 (cadar comb-sort-list))) (cond ((int-ext-intersection-equal sort1 sort2) (complete-taxonomy1 (cdr comb-sort-list))) (t (rf-format "Taxonomy is not complete: ~a ~a ~%" sort1 sort2)))) t)) (defun int-ext-intersection-equal (sort1 sort2) (let ((int-intersection (intensional-intersection sort1 sort2)) (ext-intersection (extensional-intersection sort1 sort2))) (null (set-difference int-intersection (cdr (get-ind*-list (get-sort-list *subsumes-individuals* ext-intersection))))))) (defun extensional-intersection (sort1 sort2) (sortbase-glb sort1 sort2)) (defun intensional-intersection (sort1 sort2) (intersection (cdr (get-ind*-list (get-sort-list *subsumes-individuals* sort1))) (cdr (get-ind*-list (get-sort-list *subsumes-individuals* sort2))))) ;************************************************************************** ; Check the taxonomy for uniqueness (i.e., there is at most one glb defined) ;************************************************************************** (defun unique-glb () (unique-glb1 (combine-all-sorts (all-sorts *subsumes-individuals*) (cdr (all-sorts *subsumes-individuals*))))) (defun unique-glb1 (comb-sort-list) (if comb-sort-list (let ((sort1 (caar comb-sort-list)) (sort2 (cadar comb-sort-list))) (cond ((<= (length (dyn-glb sort1 sort2)) 1) (unique-glb1 (cdr comb-sort-list))) (t (rf-format "Taxonomy is not well defined: ~a ~a ~%" sort1 sort2)))) t)) (defun dyn-glb (sort1 sort2) (remove-subsumed-clbs (clb sort1 sort2))) (defun clb (sort1 sort2) (intersection (cdr (get-sub*-list (get-sort-list *subsumes-individuals* sort1))) (cdr (get-sub*-list (get-sort-list *subsumes-individuals* sort2))))) (defun remove-subsumed-clbs (clbs) (rsl clbs nil)) (defun rsl (list1 list2) (cond ((null list1) list2) (t (let ((clb (car list1)) (clb-rest (cdr list1))) (rsl (rsl1 clb clb-rest) (cons clb (rsl1 clb list2))))))) (defun rsl1 (clb list2) (cond ((null list2) nil) ((subsumes+ clb (car list2)) (rsl1 clb (cdr list2))) (t (cons (car list2) (rsl1 clb (cdr list2)))))) (defun subsumes+ (sort1 sort2) (member sort2 (get-sub*-list (get-sort-list *subsumes-individuals* sort1)))) ;* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * (defun compile-sortbase (sortbase) (setq *subsumes-individuals* (and (compile1-sortbase sortbase) (classify-subsumes* (classify-sortbase))))) ;* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * (defvar *subsumes-individuals* nil) ;************************************************************************ ; Explicit relations: subsumes and individuals ;************************************************************************ ;The structure of *subsumes-individuals* after the first compilation step ;(compile1-sortbase) : ;( (sort1 (subsumes subsort11 subsort12 ...) (individuals ind11 ind12 ...)) ; (sort2 (subsumes subsort21 subsort22 ...) (individuals ind21 ind22 ...)) ; (sort3 (subsumes subsort31 subsort32 ...) (individuals ind31 ind32 ...)) ; ... ; (sortn (subsumes subsortn1 subsortn2 ...) (individuals indn1 indn2 ...)) ;) ;* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * (defun compile1-sortbase (sortbase) (cond (sortbase (let ((clause (car sortbase))) (cond ((subsumes-t clause) (let ((sort (cadadr clause)) (subsort (caddr (cadr clause)))) (add-sort-and-subsort sort subsort))) ((horn-sort-rel-t clause) (let ((sort (caadr clause)) (subsort (caaddr clause))) (add-sort-and-subsort sort subsort))) ((individual-assignment-t clause) (let ((sort (caadr clause)) (individual (cadadr clause))) (cond ((dom-t individual) (mapcar #'(lambda (dom-individual) (add-sort-and-individual sort dom-individual)) (cdr individual))) (t ;individual is a constant (add-sort-and-individual sort individual))))))) (compile1-sortbase (cdr sortbase))) (t *subsumes-individuals*))) ;* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * (defun add-sort-and-subsort (sort subsort) (cond ((null *subsumes-individuals*) (initial-subsumes-individuals1 sort subsort)) ((member-tree sort *subsumes-individuals*) (assert-sub sort subsort)) (t (assert-sort1 sort subsort)))) (defun add-sort-and-individual (sort individual) (cond ((null *subsumes-individuals*) (initial-subsumes-individuals2 sort individual)) ((member-tree sort *subsumes-individuals*) (assert-individuals sort individual)) (t (assert-sort2 sort individual)))) (defun initial-subsumes-individuals1 (sort subsort) (setq *subsumes-individuals* (list (list sort (list 'subsumes subsort) (list 'individuals)) (list subsort (list 'subsumes) (list 'individuals))))) (defun initial-subsumes-individuals2 (sort individual) (setq *subsumes-individuals* (list (list sort (list 'subsumes) (list 'individuals individual))))) ;Asserts a sort in the *subsumes-individuals* with the subsorts of the ;`Subsumes-List' and asserts the subsorts in the *subsumes-individuals*, ;if not existent yet (defun assert-sort1 (sort subsort) (setq *subsumes-individuals* (append *subsumes-individuals* (list (list sort (list 'subsumes subsort) (list 'individuals))))) (cond ((member-tree subsort *subsumes-individuals*) t) (t (assert-subsort subsort)))) ;Asserts a sort in the *subsumes-individuals* with the individual in the ;`individual-list' (defun assert-sort2 (sort individual) (setq *subsumes-individuals* (append *subsumes-individuals* (list (list sort (list 'subsumes) (list 'individuals individual)))))) ;Asserts a subsort in the `subsumes-list', if not existent yet and ;asserts this subsort in the *subsumes-individuals*. (defun assert-sub (sort subsort) (setq *subsumes-individuals* (mapcar #'(lambda (list) (cond ((and (equal sort (car list)) (not (member subsort (cadr list)))) (list (car list) (append (cadr list) (list subsort)) (caddr list))) (t list))) *subsumes-individuals*)) (cond ((member-tree subsort *subsumes-individuals*) t) (t (assert-subsort subsort)))) ;Assert a subsort in the *subsumes-individuals* (defun assert-subsort (subsort) (setq *subsumes-individuals* (append *subsumes-individuals* (list (list subsort (list 'subsumes) (list 'individuals)))))) ;Assert an individual of the sort in the `individual-list' (defun assert-individuals (sort individual) (setq *subsumes-individuals* (mapcar #'(lambda (list) (cond ((equal sort (car list)) (list (car list) (cadr list) (append (caddr list) (list individual)))) (t list))) *subsumes-individuals*))) ;* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * (defun horn-sort-rel-t (clause) (= (length clause) 3) ) (defun individual-assignment-t (clause) (= (length clause) 2)) (defun member-tree (sort subsumes-individuals) (and subsumes-individuals (if (equal sort (caar subsumes-individuals)) t (member-tree sort (cdr subsumes-individuals))))) ;************************************************************************ ; Transitive closure: subsumes* and individuals* ;************************************************************************ (defun classify-sortbase () ;1. Add to the *subsumes-individuals* the `subsumes*-list' with the ; sorts of the `subsumes-list' and the `individual*-list' ; with the individuals of the `individual-list' (setq *subsumes-individuals* (extend-sub-ind-list *subsumes-individuals*)) ;2. Add all elements from the stratified list ; a. `subsumes-list' is empty -> finished ; b. `subsumes-list' is not empty -> ; add all elements from the `subsumes-list' ; (expand `subsumes*-list' with the `subsumes*-list' ; (of each element and `individual*-list' analogue) (expand-sort-list (stratify-list *subsumes-individuals*))) (defun extend-sub-ind-list (sub-ind-list) (mapcar #'(lambda (sort-list) (append sort-list (list (cons 'subsumes* (cons (car sort-list) (cdadr sort-list))) (cons 'individuals* (cdaddr sort-list))))) sub-ind-list)) ;* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * (defvar *stratified-list* nil) (defun stratify-list (subsumes-list) (setq *stratified-list* (sort-depexpr (mk-subsumes-list subsumes-list)))) (defun mk-subsumes-list (sub-ind-list) (mapcar #'(lambda (x) (cons (car x) (cdadr x))) sub-ind-list)) ;* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * (defun expand-sort-list (stratified-list) (cond ((null stratified-list) *subsumes-individuals*) (t (let ((sort (car stratified-list))) (setq *subsumes-individuals* (mapcar #'(lambda (sort-list) (cond ((sort-list-t sort-list sort) (expand-sub*-ind* sort-list)) (t sort-list))) *subsumes-individuals*)) (expand-sort-list (cdr stratified-list)))))) (defun expand-sub*-ind* (sort-list) (let ((sort (car sort-list)) (sub-list (get-sub-list sort-list)) (ind-list (get-ind-list sort-list)) (sub*-list (get-sub*-list sort-list)) (ind*-list (get-ind*-list sort-list))) (list sort sub-list ind-list (expand-sub* sub*-list (cdr sub-list)) (expand-ind* ind*-list (cdr sub-list))))) (defun expand-sub* (sub*-list sub-list) (cond ((null sub-list) sub*-list) (t (expand-sub* (append-not-twice sub*-list (get-sub*-list (get-sort-list *subsumes-individuals* (car sub-list)))) (cdr sub-list))))) (defun expand-ind* (ind*-list sub-list) (cond ((null sub-list) ind*-list) (t (expand-ind* (append-not-twice ind*-list (get-ind*-list (get-sort-list *subsumes-individuals* (car sub-list)))) (cdr sub-list))))) (defun get-sort-list (sub-ind-list sort) (when sub-ind-list (let ((sort-list (car sub-ind-list))) (cond ((equal (car sort-list) sort) sort-list) (t (get-sort-list (cdr sub-ind-list) sort)))))) (defun get-sub*-list (sort-list) ; returned 'lists' start with sub/ind[*] tag (cadddr sort-list)) (defun get-ind*-list (sort-list) (car (last sort-list))) (defun get-sub-list (sort-list) (cadr sort-list)) (defun get-ind-list (sort-list) (caddr sort-list)) (defun append-not-twice (sub*-list1 sub*-list2) (cond ((null sub*-list2) sub*-list1) (t (cond ((member (car sub*-list2) sub*-list1 :test #'equal) (append-not-twice sub*-list1 (cdr sub*-list2))) (t (append-not-twice (append sub*-list1 (list (car sub*-list2))) (cdr sub*-list2))))))) (defun sort-list-t (sort-list sort) (equal (car sort-list) sort)) ;******************************************************************************* (defun classify-subsumes* (sub-ind-list) (mapcar #'(lambda (sort-list) (let ((sort (car sort-list)) (sub-list (get-sub-list sort-list)) (ind-list (get-ind-list sort-list)) (sub*-list (get-sub*-list sort-list)) (ind*-list (get-ind*-list sort-list))) (list sort sub-list ind-list (sort-subsumes* sub*-list *stratified-list*) ind*-list))) sub-ind-list)) (defun sort-subsumes* (a b) (sort (copy-list a) #'(lambda (y x) (member y (member x b))))) ;;;### eof ;;;### File "horizon.lisp" ; flatten-database eliminates active calls in tup calls, before passtup ; untup introduces binary cns nestings ; flatten-struc-database eliminates these cns and other passive nestings ; passtup could not passivate these cns calls (defun horizon-database (db &optional lambda-mode) (if lambda-mode ; tranformations needed inside lambda expressions: ; unor/unmacro/.../undeclare have already been made (footen-database '(true) (normalize-database (deanon-database (passtup (flatten-struc-database (untup-database ; (flatten-database (uncomma (hotrans (unlambda db))))))))) ;) (footen-database '(true) (normalize-database (deanon-database (passtup (flatten-struc-database (untup-database ; (flatten-database (uncomma (hotrans (unlambda (unor (unmacro (untype (orf2 (undeclare db)))))))))))))))) ;) ; the following identity functions for horizoning will normally be overloaded ; e.g. the real function normalize-database has to be imported ; from the file normalizer.lisp: (defun normalize-database (db) db) ; further transformations obtainable from Michael Sintek: (defun uncomma (db) db) (defun hotrans (db) db) (defun unlambda (db) db) (defun unor (db) db) (defun unmacro (db) db) (defun untype (db) db) ; incl. orfn (defun orf2 (db) db) ; U.B. (defun undeclare (db) db) ;;; Functions needed to run rfi as a stand-alone program: #-CLiCC (progn ; user-defined "#+-"-features not supported by CLiCC at ; compile time: in CLiCC rfi.lisp must thus not be ; loaded without syntra.lisp #-rf-tracer (defun tracer-reset-to-zero () nil) ; defined by tracer.lisp #-rf-tracer (defun tracer-reset-to-max () nil) ; defined by tracer.lisp #-rf-comment (defun com-cell-p (expr) nil) ; defined by comment.lisp #-rf-comment (defvar *comment-style* nil) ; defined by comment.lisp ) ; the following error functions for RuleGen will normally be overloaded (defun rulegen-load-database (userline) "This function is redefined by RuleGen." (rf-error "RuleGen is not loaded") ) (defun rulegen-query (userline) "This function is redefined by RuleGen." (rf-error "RuleGen is not loaded") ) ; ----------------------------------------------------------------------------- ; ; untup function ; something like `(tup a b | _x) is transformed to `(cns a (cns b _x)) ; this means: ; - only passive tup structures are transformed ; (i.e. tups in the head and instantiated tups in the body ; and on the left-hand side of is) ; ; ; ----------------------------------------------------------------------------- (defun untup-database (db) ; (mapcar #'untup-clause db)) (cond ((null db) nil) ((equal '(tup) (s-head (car db))) (untup-database (cdr db))) ; del (tup) def (t (cons (untup-clause (car db)) (untup-database (cdr db)))))) (defun untup-clause (clause) (tuptocons1 clause)) ; (cons (s-kind clause) ; (cons (if (equal '(tup) (s-head clause)) ; '(tup) ; leaving (tup) as is ; (tuptocons1 (s-head clause))) ; (tuptocons-passive (s-premises clause))))) ;(defun tuptocons-passive (x) ; (cond ((is-t x) ; (mk-is (tuptocons1 (s-patt-is x)) (tuptocons-passive (s-expr-is x)))) ; ((inst-t x) (mk-inst (tuptocons1 (un-inst x)))) ; ((final-p x) x) ; (t (cons (tuptocons-passive (car x)) (tuptocons-passive (cdr x)))))) (defun consit (lis) (cond ((null lis) nil) ;------------ throw out if and when dotted-tup untupping becomes forbidden----- ; ((atom lis) lis) ; ((vari-t lis) lis) ;------------------------------------------------------------------------------ ((bar-t lis) (tuptocons1 (cadr lis))) ; cddr should be nil (t (list 'cns (tuptocons1 (car lis)) (consit (cdr lis)))) ) ) (defun tuptocons (item) (if (tup-t item) (tuptocons1 item) (rf-error "(tuptocons): tup expected")) ) (defun tuptocons1 (item) (cond ((null item) nil) ((inst-t item) (mk-inst (tuptocons1 (un-inst item)))) ((final-p item) item) ; ((atom item) item) ; ((vari-t item) item) ((tup-t item) (cond ((bar-t (cdr item)) (rf-error "(tuptocons1): tup with leading | not untuppable")) (t (consit (cdr item))))) (t (cons (tuptocons1 (car item)) (tuptocons1 (cdr item)))) ) ) ; ----------------------------------------------------------------------------- ; ; passtup: passivate active tup's and cns's ; Michael Christen/HB ; ; ----------------------------------------------------------------------------- (defun passtup (kb) (mapcar #'passtup-clause kb)) (defun passtup-clause (clause) (cons (car clause) ; ft or hn (cons (cadr clause) ; head (passtup-body (cddr clause))))) ; body (defun passtup-body (body) (mapcar #'passtup-literal body)) (defun passtup-literal (literal) (cond ((final-p literal) literal) ((is-t literal) (mk-is (s-patt-is literal) (passtup-literal (s-expr-is literal)))) ((or (tup-t literal) (cns-t literal)) ; active tup or cns (passtup-tup (cons (car literal) (passtup-body (cdr literal))))) (t (passtup-body literal)))) (defun passtup-tup (tup-literal) (let ((objl (cdr tup-literal))) (cond ((passtup-objl-inactive-p objl) (mkk-inst (cons (car tup-literal) (mapcar #'un-inst objl)))) (t tup-literal)))) ;are objects in list variables or constants ? (defun passtup-objl-inactive-p (objl) (every #'passtup-obj-inactive-p objl)) (defun passtup-obj-inactive-p (obj) (or (final-p obj) (eq '\| obj))) ; ----------------------------------------------------------------------------- ; ; footen-function ; ; ----------------------------------------------------------------------------- (defun footen-database (foot-list db) (mapcar #'(lambda (x) (footen-clause foot-list x)) db)) (defun footen-clause (foot-list clause) (if (and (eq 'hn (s-kind clause)) (s-premises clause)) (cons 'ft (cons (s-head clause) (append (s-premises clause) foot-list))) clause)) ; ----------------------------------------------------------------------------- ; ; footer-function ; ; ----------------------------------------------------------------------------- (defun footer-database (foot-list db) (mapcar #'(lambda (x) (footer-clause foot-list x)) db)) (defun footer-clause (foot-list clause) (if (eq 'hn (s-kind clause)) (cons 'ft (cons (s-head clause) (append (s-premises clause) foot-list))) clause)) ; ----------------------------------------------------------------------------- ; ; uncertain-function ; Victoria Hall ; ; ----------------------------------------------------------------------------- ;Neither the compiler nor the interpreter can use uc clauses directly, ;so they have to be translated into ordinary footed (ft) clauses. (defun switch-tag (clause old-tag new-tag) (if (eq (car clause) old-tag) (cons new-tag (cdr clause)) clause)) (defun mk-combfct (combfct body) ;; should be named "combfct-applic" (cons combfct body)) (defun from-uc-to-ft (clause combfct) (cond ((ucfact-t clause) (switch-tag clause 'uc 'ft)) ((uc-tt clause) (list 'ft (s-head clause) (mk-combfct combfct (s-premises clause)))))) ;Translate a clause (hn & ft clauses stay unmodified) (defun uncertain-clause (clause combfct) (cond ((uc-tt clause) (from-uc-to-ft clause combfct)) (t clause))) ;Translate a database (defun uncertain-database (db combfct) (mapcar #'(lambda (clause) (uncertain-clause clause combfct)) db)) ;Translate and reassign the *rfi-database* (RELFUN database) (defun uncertain-db (combfct) (set-database (uncertain-database (get-database) combfct)) t) ; ----------------------------------------------------------------------------- ; ; deanonymizer ; ; ----------------------------------------------------------------------------- (defun deanon-request (request) (car (nam-ano t request '(1 0) nil))) (defun deanon-database (database) (mapcar #'deanon-clause database)) (defun deanon-clause (clause) (let ((variables (collect-variables clause))) (let ((headclause-carvarnuml ; passive context (nam-ano nil (s-head clause) (nextnew '(0) variables) variables))) (let ((premisesclause-cdrvarnuml ; active context (nam-ano t (s-premises clause) (cadr headclause-carvarnuml) variables))) (cons (s-kind clause) (cons (car headclause-carvarnuml) (car premisesclause-cdrvarnuml))))))) (defun nam-ano (activenv term varnuml oldvars) (cond ((anonymous-p term) (list (legnumvar varnuml) (nextnew varnuml oldvars))) ((bnd-t term) (cond ((and (typexcdom-p (s-variable-bnd term)) (typexcdom-p (s-expr-bnd term))) (list (mk-bnd (mk-bnd (legnumvar varnuml) (s-variable-bnd term)) (s-expr-bnd term)) (nextnew varnuml oldvars))) ((typexcdom-p (s-variable-bnd term)) (let ((exprbnd-exprvarnuml (nam-ano activenv (s-expr-bnd term) varnuml oldvars))) (list (mk-bnd (s-variable-bnd term) (car exprbnd-exprvarnuml)) (cadr exprbnd-exprvarnuml)))) ((typexcdom-p (s-expr-bnd term)) (let ((pattbnd-pattvarnuml (nam-ano activenv (s-variable-bnd term) varnuml oldvars))) (list (mk-bnd (car pattbnd-pattvarnuml) (s-expr-bnd term)) (cadr pattbnd-pattvarnuml)))) (t (let ((pattbnd-pattvarnuml (nam-ano activenv (s-variable-bnd term) varnuml oldvars))) (let ((exprbnd-exprvarnuml (nam-ano activenv (s-expr-bnd term) (cadr pattbnd-pattvarnuml) oldvars))) (list (mk-bnd (car pattbnd-pattvarnuml) (car exprbnd-exprvarnuml)) (cadr exprbnd-exprvarnuml))))))) ((or (atom term) (vari-t term)) (list term varnuml)) ((typexcdom-p term) (list (cond ((and activenv (typ-t term)) (mkk-inst (mk-bnd (legnumvar varnuml) term))) (activenv term) (t (mk-bnd (legnumvar varnuml) term))) (nextnew varnuml oldvars))) ((inst-t term) (let ((arginst-carvarnuml (nam-ano nil (cadr term) varnuml oldvars))) (list (mkk-inst (car arginst-carvarnuml)) (cadr arginst-carvarnuml)))) ((is-tt term) (let ((pattis-carvarnuml (nam-ano nil (s-patt-is term) varnuml oldvars))) (cond ((and (vari-t (s-patt-is term)) (typexcdom-p (un-inst (s-expr-is term)))) (list (mk-is (car pattis-carvarnuml) (s-expr-is term)) (cadr pattis-carvarnuml))) (t (let ((expris-cdrvarnuml (nam-ano activenv (s-expr-is term) (cadr pattis-carvarnuml) oldvars))) (list (mk-is (car pattis-carvarnuml) (car expris-cdrvarnuml)) (cadr expris-cdrvarnuml))))))) (t (let ((carterm-carvarnuml (nam-ano activenv (car term) varnuml oldvars))) (let ((cdrterm-cdrvarnuml (nam-ano activenv (cdr term) (cadr carterm-carvarnuml) oldvars))) (list (cons (car carterm-carvarnuml) (car cdrterm-cdrvarnuml)) (cadr cdrterm-cdrvarnuml))))))) ; ----------------------------------------------------------------------------- ; ; singlifier ; ; ----------------------------------------------------------------------------- (defun singlify-database (database) (mapcar #'singlify-clause database)) (defun singlify-clause (clause) (cond ((hn-t clause) (cons (s-kind clause) (cons (singlify-head (s-head clause)) (singlify-body (s-premises clause))))) ((ft-t clause) (cons (s-kind clause) (cons (singlify-head (s-head clause)) (mk-premises (singlify-body (s-mbody clause)) (singlify-values (s-mfoot clause)))))) (t (rf-error "(singlify-clause): undefined clause type")))) (defun singlify-body (terms) (mapcar #'singlify-term terms)) (defun singlify-term (term) (cond ((or (final-p term) (final-mis-p term)) term) ((is-t term) (cond ((lisp-builtin-p (car (s-expr-mis term))) (mk-is (s-patt-is term) (list (car (s-expr-mis term)) '\| (singlify-values (cdr (s-expr-mis term)))))) (t (mk-is (cons 'tup (s-patt-mis term)) (singlify-nested (s-expr-mis term)))))) ((lisp-builtin-p (car term)) (list (car term) '\| (singlify-values (cdr term)))) (t (list (car term) (singlify-values (cdr term)))))) (defun singlify-nested (term) (cond ((final-mis-p term) (list 'tup term)) ((is-t term) (cond ((lisp-builtin-p (car (s-expr-mis term))) (list 'tup (mk-is (s-patt-is term) (list (car (s-expr-mis term)) '\| (singlify-values (cdr (s-expr-mis term))))))) (t (mk-is (cons 'tup (s-patt-mis term)) (singlify-nested (s-expr-mis term)))))) ((lisp-builtin-p (car term)) (list 'tup (list (car term) '\| (singlify-values (cdr term))))) (t (list (car term) (singlify-values (cdr term)))))) (defun singlify-values (term) (let ((terms (singlify-value term nil))) (cond ((null terms) (mkk-inst (list 'tup))) ((null (cdr terms)) (car terms)) (t (cons 'appifun terms))))) ;(defun singlify-values (terms) ; (cond ((null terms) (mkk-inst (list 'tup))) ; ((null (cdr terms)) (singlify-value (car terms))) ; (t (cons 'appifun (mapcar #'singlify-value terms))))) (defun singlify-value (term finals) (cond ((and finals (null term)) (list (mkk-inst (cons 'tup (reverse finals))))) ((null term) nil) ((final-p (car term)) (singlify-value (cdr term) (cons (un-inst (car term)) finals))) (finals (cons (mkk-inst (cons 'tup (reverse finals))) (cons (singlify-nested (car term)) (singlify-value (cdr term) nil)))) (t (cons (singlify-nested (car term)) (singlify-value (cdr term) nil))))) ;(defun singlify-value (term) ; (cond ((eq '\| term) term) ; ((final-p term) (mkk-inst (list 'tup (un-inst term)))) ; (t (singlify-nested term)))) (defun singlify-head (term) (list (car term) (cons 'tup (cdr term)))) ; ----------------------------------------------------------------------------- ; ; extrarger ; ; ----------------------------------------------------------------------------- (defun extrarg-database (database) (mapcar #'extrarg-clause database)) (defun extrarg-clause (clause) (cond ((hn-t clause) (cons (s-kind clause) (cons (s-head clause) (extrarg-body (s-premises clause))))) ((ft-t clause) (let ((foot (s-foot clause))) (cond ((final-p foot) (cons 'hn (cons (extrarg-head (s-head clause) (un-inst foot)) (extrarg-body (s-body clause))))) (t (let ((newvar (legnumvar (nextnew '(0) (collect-variables clause))))) (cons 'hn (cons (extrarg-head (s-head clause) newvar) (mk-premises (extrarg-body (s-body clause)) (extrarg-foot foot newvar))))))))) (t (rf-error "(extrarg-clause): undefined clause type")))) (defun extrarg-body (terms) (mapcar #'extrarg-term terms)) (defun extrarg-term (term) (cond ((final-is-p term) term) ((is-t term) (cond ((lisp-builtin-p (car (s-expr-is term))) term) (t (cons (car (s-expr-is term)) (cons (mk-inst (s-patt-is term)) (cdr (s-expr-is term))))))) (t term))) (defun extrarg-head (term val) (cons (car term) (cons val (cdr term)))) (defun extrarg-foot (term val) (cond ((lisp-builtin-p (car term)) (mk-is val term)) (t (cons (car term) (cons val (cdr term)))))) ; ----------------------------------------------------------------------------- ; ; static flattener ; ; ----------------------------------------------------------------------------- (defun flatten-request (request) (and-flattener nil request nil '(1 -1))) (defun flatten-database (database) (mapcar #'flatten-clause database)) (defun flatten-struc-database (database) (mapcar #'flatten-struc-clause database)) (defun flatten-clause (clause) (let ((variables (collect-variables clause))) (cons (s-kind clause) (cons (s-head clause) (and-flattener nil (s-premises clause) variables (nextnew '(0) variables)))))) (defun flatten-struc-clause (clause) (let ((variables (collect-variables clause))) (cons (s-kind clause) (let ((conjunction-conclusion-varnuml (static-flattener 'h (s-conclusion clause) (nextnew '(0) variables) variables))) (cons (cond ;((cut-p clause) (list 'cut (cadr conjunction-conclusion-varnuml))) (t (cadr conjunction-conclusion-varnuml))) (and-flattener t (append (car conjunction-conclusion-varnuml) ; general cut should go here (s-premises clause)) variables (caddr conjunction-conclusion-varnuml))))))) (defun and-flattener (struc list-of-terms oldvars varnuml) (cond ((null list-of-terms) nil) (t (let ((term (car list-of-terms))) (cond ((and struc (is-tt term) (not (convar-p (s-patt-is term)))) (let ((varstruct (legnumvar varnuml))) ; complex is lhs gets (and-flattener struc (cons (mk-is varstruct ; replaced by new var (mk-inst (s-patt-is term))) (cons (mk-is varstruct ; using TWO is (s-expr-is term)) (cdr list-of-terms))) oldvars (nextnew varnuml oldvars)))) ((nonstrict-p (un-is term)) (let* ((nonstrictflat (and-flattener struc (cdr (un-is term)) oldvars varnuml)) ; since and-flattener does not return new varnuml ; its newly introduced variables must be reconstructed: (newvars (append oldvars (collect-variables nonstrictflat)))) (cons (gen-is term (cons (car (un-is term)) nonstrictflat)) (and-flattener struc (cdr list-of-terms) newvars (nextnew varnuml newvars))))) ((or (and struc (or (convar-p term) (convar-is-p term) (flat-struc-p term) (flat-struc-is-p term))) (and (not struc) (or (final-p term) (final-is-p term) (flat-p term) (flat-is-p term)))) (cons term (and-flattener struc (cdr list-of-terms) oldvars varnuml))) (t (let ((conjunction-goal-varnuml (static-flattener struc (un-is term) varnuml oldvars))) (and-flattener struc (append (car conjunction-goal-varnuml) (cons (gen-is term (cadr conjunction-goal-varnuml)) (cdr list-of-terms))) oldvars (caddr conjunction-goal-varnuml))))))))) (defun static-flattener (struc term varnuml oldvars) (cond ((or (and struc (convar-p term)) (and (not struc) (final-p term))) (list nil term varnuml)) ((is-tt term) (list (cons term nil) (mk-inst (s-patt-is term)) varnuml)) ; ((ecal-t term) ; (let ((varstruct (legnumvar varnuml))) ; (list (cons (mk-is varstruct term) ; nil) ; varstruct ; (nextnew varnuml oldvars)))) ((and struc (inst-t term)) (let ((conjunction-goal-varnuml (static-flattener 'h (cadr term) varnuml oldvars))) (list (car conjunction-goal-varnuml) (mk-inst (cadr conjunction-goal-varnuml)) (caddr conjunction-goal-varnuml)))) ((or (and struc (convar-p (car term))) (and (not struc) (final-p (car term)))) (let ((conjunction-goal-varnuml (static-flattener struc (cdr term) varnuml oldvars))) (list (car conjunction-goal-varnuml) (cons (car term) (cadr conjunction-goal-varnuml)) (caddr conjunction-goal-varnuml)))) (t (let ((varstruct (legnumvar varnuml)) (conjunction-goal-varnuml (static-flattener struc (cdr term) (nextnew varnuml oldvars) oldvars))) (list (cons (mk-is varstruct (cond ((eq struc 'h) (mk-inst (car term))) (t (car term)))) (car conjunction-goal-varnuml)) (cons varstruct (cadr conjunction-goal-varnuml)) (caddr conjunction-goal-varnuml)))))) (defun legnumvar (varnuml) (cons 'vari (cons (intern (princ-to-string (car varnuml))) (cdr varnuml)))) (defun collect-variables (clause) (cond ((atom clause) nil) ((vari-t clause) (list (name-of clause))) (t (append (collect-variables (car clause)) (collect-variables (cdr clause)))))) (defun collect-variables* (term) (cond ((atom term) nil) ((vari-t term) (list term)) (t (append (collect-variables* (car term)) (collect-variables* (cdr term)))))) (defun nextnew (varnuml oldvars) (let ((incr (+ (car varnuml) 1))) (let ((incrl (cons incr (cdr varnuml)))) (cond ((member incr oldvars) (nextnew incrl oldvars)) (t incrl))))) ;************************************************************************** ; Replace subsumes facts by ordinary rules V. Hall ;************************************************************************** (defun unsubsumes (database) (mapcar #'(lambda (clause) (cond ((subsumes-t clause) (list 'hn (list (cadadr clause) '(vari x)) (list (cadr (cdadr clause)) '(vari x)))) (t clause))) database)) (defun subsumes-t (clause) ; should be fact of the form (hn (subsumes p q)) (and (hn-t clause) (equal (caadr clause) 'subsumes))) ;************************************************************************** ; Replace ordinary rules by subsumes facts V. Hall ;************************************************************************** (defun resubsumes (database) (mapcar #'(lambda (clause) (cond ((sortrule-t clause) (list 'hn (list 'subsumes (caadr clause) (caaddr clause)))) (t clause))) database)) (defun sortrule-t (clause) ; should be rule of the form (hn (p _x) (q _x)) (and (hn-t clause) (= (length clause) 3) (= (length (cadr clause)) 2) (= (length (caddr clause)) 2))) ;;;### eof ;;;### File "reconsult.lisp" ; ----------------------------------------------------------------------------- ; ; pure reconsult transformation merging two clause lists into one ; Michael Herfert ; ; ----------------------------------------------------------------------------- (defun reconsult (rec-db old-db) "Reconsults a database. No sideeffect. Searches rec-db for procedures. If a procedure p is found all of its clauses are deleted from old-db. Then the clauses of p are copied to old-db to the position where the first clause of it stood. If there are later more clauses for p in rec-db they are appended to the end of old-db. So reconsult is not well suited for object-centered programming. This is not due to a quick implementation but there are semantic problems wiht reconsult and object-centered style. An alternative for reconsult is to use small, fast loading modules. " (reconsult-aux rec-db old-db nil)) (defun reconsult-aux (rec-db new-db seen-operators) "Returns the new database." (if (null rec-db) new-db (let* ((clause (first rec-db)) (operator (first (s-head clause))) ) (reconsult-aux (reconsult-search-next rec-db operator) (reconsult-operator rec-db new-db operator seen-operators) ;; does not matter if operator is more then one time in seen-operators (cons operator seen-operators) )))) (defun reconsult-split-db (db operator left) "Returns a list: (left right), where left is the list of clauses of db before the first clause having operator as operator. right is the list of clauses starting with the first clause having operator as operator." (if (null db) (list (reverse left) nil) (let* ((clause (first db)) (operator-of-clause (first (s-head clause))) ) (if (equal operator operator-of-clause) (list (reverse left) db) (reconsult-split-db (rest db) operator (cons clause left) ))))) (defun reconsult-search-next (db operator) "Returns db starting with the first clause without operator as operator." (if (null db) nil (let* ((clause (first db)) (operator-of-clause (first (s-head clause))) ) (if (equal operator operator-of-clause) (reconsult-search-next (rest db) operator) db )))) (defun reconsult-search-clauses (rec-db operator result) "Returns a list of all clauses at the beginning of rec-db having operator as operator." (if (null rec-db) (reverse result) (let* ((clause (first rec-db)) (operator-of-clause (first (s-head clause))) ) (if (equal operator operator-of-clause) (reconsult-search-clauses (rest rec-db) operator (cons clause result) ) (reverse result) )))) (defun reconsult-operator (rec-db new-db operator seen-operators) (let* ((left-right (reconsult-split-db new-db operator nil)) (left (first left-right)) (right (second left-right)) (clauses (reconsult-search-clauses rec-db operator nil)) ) (if (member operator seen-operators :test #'equal) ;; old clauses of operator are already removed: (append new-db clauses) ;; remove old clauses, replace with new ones: (append left clauses ; block of new clauses (remove operator right :key #'caadr :test #'equal))))) ;;;### eof ;;;### File "fileio.lisp" ; ----------------------------------------------------------------------------- ; ; i/o functions for filesystem ; ; ----------------------------------------------------------------------------- (defun rfi-string (x) (cond ((null x) "") ((stringp x) x) ((symbolp x) (string-downcase (string x))) (t ""))) (defun rfi-string+blank (x) (concatenate 'string (rfi-string x) " ")) (defun rfi-userline-string (userline) (apply #'concatenate 'string (mapcar #'rfi-string+blank userline))) ; The feature our-fs controls presence of path-name extension module our-fs.lisp #-our-fs (defun rfi-extension (file extension &aux (filename (rfi-string file))) (let ((slash (position #\/ filename :from-end t)) (point (position #\. filename :from-end t))) (cond ((string/= filename "") (cond ((or (and slash point (< slash point)) (and (null slash) point)) filename) ((or (and slash point (> slash point)) (null point)) (concatenate 'string filename extension)))) (t (rf-error "(rfi-extension): " (format nil "~A" filename) " filename must be of type string or symbol!"))))) #+our-fs (defun rfi-extension (file extension) (let ((filename (rfi-string file))) (if (string= filename "") (rf-error "(rfi-extension): " (format nil "~A" filename) " filename must be of type string or symbol!") (namestring (our-fs:logdir-file (if (char= (char filename 0) #\/) :root :current-directory) filename :force T :suffixl (list (subseq extension 1))))))) (defun rfi-change-prelude (oldclause newclause) (let ((getprelude (get-sysbase 'prelude))) (unless (member newclause getprelude :test #'equal) ; newclause there: noop (set-sysbase 'prelude (subst newclause oldclause getprelude :test #'equal))))) (defun rfi-load-prelude nil (let* ((*style* 'lisp) (prelude #+our-fs (concatenate 'string (namestring (our-fs:logdir-dir :RFM)) "prelude.rf") #-our-fs "prelude.rf")) (if (probe-file prelude) (set-sysbase 'prelude (rfi-cmd-consult-1 prelude)) (rf-print "REMARK (rfi-load-prelude): no prelude.rf could be loaded")))) (defun rfi-load-tracer (&optional (leading-directory #+our-fs (namestring (our-fs:logdir-dir :RFI)))) ;; e.g.: leading-directory = "../relfun/" (let ((fullname-pro (if leading-directory (concatenate 'string leading-directory "tracer.rfp") "tracer.rfp") ) (fullname-lisp (if leading-directory (concatenate 'string leading-directory "tracer.rf") "tracer.rf") )) (cond ((not (boundp 'tracer))) ; no tracer available ((probe-file fullname-pro) (let ((*style* 'prolog)) (set-sysbase 'tracebase (rfi-cmd-consult-1 fullname-pro)))) ((probe-file fullname-lisp) (let ((*style* 'lisp)) (set-sysbase 'tracebase (rfi-cmd-consult-1 fullname-lisp)))) (t (rf-print "REMARK (rfi-load-tracer): no tracer could be loaded") )))) (defun rfi-cmd-replace (userline &aux (filename (rfi-extension (cadr userline) (rf-or-rfp) ))) (if (probe-file filename) (set-database (rfi-cmd-consult-1 filename)) (rf-error "(rfi-cmd-replace): " filename " file doesn't exist!"))) ;; Default file-extension is style-dependent: (defun rf-or-rfp () "Returns the default file-extension" (if (eq 'prolog *style*) ".rfp" ".rf" )) (defun rfi-cmd-consult (userline) (let* ((filename (rfi-extension (cadr userline) (rf-or-rfp)))) (if (probe-file filename) (set-database (append (get-database) (rfi-cmd-consult-1 filename))) (rf-error "(rfi-cmd-consult): " filename " file doesn't exist!")))) (defun rfi-cmd-reconsult (userline) "userline = (reconsult ) " (let ((filename (rfi-extension (cadr userline) (rf-or-rfp)))) (if (probe-file filename) (set-database (reconsult (rfi-cmd-consult-1 filename) (get-database) )) (rf-error "(rfi-cmd-reconsult): " filename " file doesn't exist!")))) (defun rfi-cmd-consult-1 (file) "Returns a list of clauses. Side-effect on *rfi-modules*. " (let* ((module-descriptor (mod-read-from-file nil file)) (sub-modules (third module-descriptor)) (db (normalize-consulted-db (fifth module-descriptor))) ) (mod-modify-descriptor *current-module* :current-context (remove-duplicates (append sub-modules (mod-get-context *current-module*))) ) db )) (defun read-db-from-file (file) (mod-spaces *module-level*) (rf-format "Reading file \"~A\"~%" file) (let* ((extension (pathname-type file)) (*style* (cond ((string= "rfp" extension) 'prolog ) ((string= "rf" extension) 'lisp) (t *style* )))) (if (eq *style* 'prolog) (pro-read-data-base file) ; returns NIL if error detected (with-open-file (ifile file :direction :input) (let ((*readtable* *rfi-readtable*)) (do ((clause nil) (tmpdb nil (cons clause tmpdb))) ((null (setq clause (read ifile nil nil nil))) (reverse tmpdb)))))) )) (defun normalize-consulted-db (db) (tag-clauses (unsetq-setqs db))) (defun unsetq-setqs (l) ; ((setq 'a ( ((a1...)...) ...)...(setq 'b (aa...)))) (apply #'append (mapcar #'unsetq-single-setq l))) (defun unsetq-single-setq (l1) (cond ((and (consp l1) (equal 'setq (car l1))) (cadr (caddr l1))) (t (list l1)))) (defun tag-clauses (db) (mapcar #'tag-single-clause db)) (defun tag-single-clause (clause) (cond ((consp (car clause)) ; ((p1...)...) instead of (ft/hn (p1...)...) (if (endp (cdr clause)) (cons 'hn clause) (cons 'ft clause))) (t clause))) (defun rfi-cmd-tell (userline) (let ((filename (rfi-extension (cadr userline) (rf-or-rfp)))) (if (probe-file filename) (if (rfi-yes-or-no-p "file already exists - overwrite? ") (progn (delete-file filename) (rfi-cmd-tell-1 filename))) (rfi-cmd-tell-1 filename)))) (defun rfi-cmd-tell-1 (file) (with-open-file (ofile file :direction :output :if-exists :supersede) (let ((*rfi-script-output* nil) (*rfi-standard-output* ofile) (db (append (mapcar #'mod-mk-sub-module (mod-get-context *current-module*) ) (get-database) )) ) (rf-pprint-db db) (fresh-line ofile)))) (defun load-ll-db (name) (let ((filename (rfi-extension name ".lisp"))) (if (probe-file filename) (catch 'stop (compile-ll-db (read-ll-db-from-file filename))) (rf-error "(load-ll-db): " filename " file doesn't exist!")))) (defun read-ll-db-from-file (filename) (rf-princ-like-lisp (format nil "; Reading file \"~A\" .." filename)) (with-open-file (ifile filename :direction :input) (do ((clause nil) (tmpdb nil (cons clause tmpdb))) ((null (setq clause (read ifile nil nil nil))) ; <<< correct this (reverse tmpdb))))) ; --------------------------------------------------------------------------- ; ; i/o functions for lisp-variables ; ; --------------------------------------------------------------------------- (defun rfi-cmd-lreplace (userline) (if (cadr userline) (if (boundp (cadr userline)) (set-database (rfi-cmd-lconsult-1 (symbol-value (cadr userline)))) (rf-print '|error (rfi-cmd-lreplace): lisp-variable isn't bound to anything!|)) (rf-print '|error (rfi-cmd-lreplace): from where?|))) (defun rfi-cmd-lconsult (userline) (if (cadr userline) (if (boundp (cadr userline)) (set-database (append (get-database) (rfi-cmd-lconsult-1 (symbol-value (cadr userline))))) (rf-print '|error (rfi-cmd-lconsult): lisp-variable isn't bound to anything!|)) (rf-print '|error (rfi-cmd-lconsult): from where?|))) (defun rfi-cmd-lconsult-1 (db) (normalize-consulted-db (let ((*readtable* *rfi-readtable*)) (read-from-string (write-to-string db))))) ; ----------------------------------------------------------------------------- ; ; script-function ; ; ----------------------------------------------------------------------------- (defun rfi-cmd-startscript (userline) (let ((filename (rfi-extension (cadr userline) ".script"))) (cond ((rfi-script-mode-p) (rf-error "(rfi-cmd-startscript): script already running!")) ((probe-file filename) (if (rfi-yes-or-no-p (concatenate 'string filename " file already exists - overwrite? ")) (progn (delete-file filename) (rfi-cmd-startscript-1 filename)))) (t (rfi-cmd-startscript-1 filename))))) (defun rfi-cmd-startscript-1 (filename) (setq *rfi-script-output* (open filename :direction :output :if-exists :supersede))) (defun rfi-cmd-endscript () (if (not (rfi-script-mode-p)) (rf-error "(rfi-cmd-endscript): no script running!") (rfi-cmd-endscript-1))) (defun rfi-cmd-endscript-1 () (let ((name (truename *rfi-script-output*))) (close *rfi-script-output*) (setq *rfi-script-output* nil) (rf-print '|script written to file |) (rf-princ name) (rf-princ '|...|) (rf-fresh-line))) ; ----------------------------------------------------------------------------- ; ; execute-function ; ; ----------------------------------------------------------------------------- (defun rfi-cmd-execute (userline) (let ((infile (rfi-extension (cadr userline) ".bat"))) (cond ;((rfi-batch-mode-p) ;(rf-error "(rfi-cmd-execute): batch already running!")) ((not (probe-file infile)) (rf-error "(rfi-cmd-execute): " infile " batchfile doesn't exist!")) (t (rfi-cmd-execute-1 infile))))) (defun rfi-cmd-execute-1 (infile) ;(rf-print '|batchjob executing...|) ;(rf-fresh-line) (relfun (open infile :direction :input) 'batch) ;(setq *rfi-script-input* (open infile :direction :input)) ;(rfi-set-batch-mode) ) ;(defun rfi-cmd-endexecute () ; (close *rfi-script-input*) ; (setq *rfi-script-input* nil) ; (rfi-set-interactive-mode) ; (rf-print '|batchjob done...|) ; (rf-fresh-line)) ; ----------------------------------------------------------------------------- ; ; help-function ; ; ----------------------------------------------------------------------------- (defun rfi-cmd-help (userline) (if (= 1 (length userline)) (rfi-cmd-help-1 "help") ; general help text (rfi-cmd-help-1 (string (cadr userline))))) ; specific help text (defun rfi-cmd-help-1 (file) (let ((filename (concatenate 'string *rfi-help-dir* (string-downcase (string file)) ".tex"))) (if (probe-file filename) (rfi-cmd-help-3 filename) (rf-print '|sorry... no help available!|)))) (defun rfi-cmd-help-3 (file) (with-open-file (ifile file :direction :input) (do ((line (read-line ifile nil nil nil) (read-line ifile nil nil nil))) ((null line)) (rfi-cmd-help-4 line) (rf-terpri)))) (defun rfi-cmd-help-4 (line) (remove-char (delete #\} (delete #\$ line)) '(#\{) )) (defun remove-char (line chars) (cond ((null chars) (remove-cmd line)) (t (let ((pos (position (car chars) line))) (cond ((not pos) (remove-char line (cdr chars))) (t (remove-char (subseq line 0 pos) (cdr chars)) (remove-char (subseq line (1+ pos)) chars)))))) ) (defun remove-cmd (line &aux (pos (position #\\ line))) (cond ((and pos (> pos 0)) (rf-princ (intern (subseq line 0 pos))) (remove-cmd (subseq line pos))) ((and pos (or (string= line "\\str") (string= line "\\stmt")))) (t (rf-princ (intern (delete #\\ line)))))) ; shell escape to UNIX for cd, pwd, ls, and subshell (!!): #-our-fs (defun rfi-cd (dir) (rf-format "Warning: cd has only effect when our-fs is loaded.~%")) #+our-fs (defun rfi-cd (dir) (if dir (our-fs:logdir-cd (rfi-string dir)) (our-fs:logdir-redef :current-directory *default-pathname-defaults*)) (when *tcl* (format t "~a{Eval:set browserdir {~a}~a}" *esc* (namestring (our-fs:logdir-pwd)) *esc*))) #-our-fs (defun rfi-pwd () (rf-format "Warning: pwd has only effect when our-fs is loaded.~%")) #+our-fs (defun rfi-pwd () (rf-format "~a~%" (namestring (our-fs:logdir-pwd)))) #+(and unix (or lucid allegro clisp kcl) our-fs) (defun rfi-ls (args) (shell (format nil "cd ~a; /bin/ls ~a" (namestring (our-fs:logdir-dir :current-directory)) (rfi-userline-string args)))) #-(and unix (or lucid allegro clisp kcl) our-fs) (defun rfi-ls (pattern) (rf-format "Warning: ls not available.~%")) #+(and unix (or lucid allegro clisp kcl) our-fs) (defun rfi-shell (args) (shell (format nil "cd ~a; ~a" (namestring (our-fs:logdir-dir :current-directory)) (if args (rfi-userline-string args) "tcsh")))) ; replace this bye "sh" or "csh" for other systems #-(and unix (or lucid allegro clisp kcl) our-fs) (defun rfi-shell (pattern) (rf-format "Warning: !! not available.~%")) ; shell escape to UNIX editor (currently, vi): #+(and unix (or lucid allegro clisp kcl)) (defun rfi-cmd-edit (userline) (let ((filename (rfi-extension (cadr userline) (rf-or-rfp)))) (when (> (shell (format nil "xterm -e vi ~a" filename)) 0) ; error (shell (format nil "vi ~a" filename))))) #-(and unix (or lucid allegro clisp kcl)) (defun rfi-cmd-edit (userline) (rf-format "Warning: edit not available.~%")) ;;;### eof ;;;### File "lispnice.lisp" ; --------------------------------------------------------------------------- ; ; pretty-printer ; ; author: R. Scheubrein ; date: March 1990 ; ; based on xlisp 1.6 pretty-printer and kkl-pretty-printer ; ; --------------------------------------------------------------------------- (defvar pp-stack* nil) (defvar pp-istack* nil) (defvar pp-currentpos* nil) (setq pp-stack* nil) (setq pp-istack* nil) (setq pp-currentpos* nil) (defmacro pp-push (*item *stack) `(setq ,*stack (cons ,*item ,*stack))) (defmacro pp-pop (*stack) `(let ((top* (car ,*stack))) (setq ,*stack (cdr ,*stack)) top*)) (defun pp-init (&optional (start-column 0)) (setq pp-stack* nil) (setq pp-istack* (list start-column)) (setq pp-currentpos* start-column)) ; The following two functions are most important to interface lisp2pro.lsp. (defun pp (*expr &optional (start-column 0)) (cond ((eq *style* 'prolog) (progn (pro-print *expr (1+ start-column)) (rf-terpri) t)) ((eq *style* 'lisp) (progn (pp-init start-column) (pp-expr *expr) (if *comment-style* ;; converter is active ==> return current column: (1+ pp-currentpos*) (progn (pp-newline) t)))) ((eq *style* 'xml) (pp-rfml-expr *expr)) )) (defun pp-clause (clause &optional (start-column 0)) (cond ((eq *style* 'prolog) (if *comment-style* ;; converter is active ==> return current col: (pro-print clause (1+ start-column)) (progn (pro-print clause (1+ start-column)) (rf-terpri) t ))) ((eq *style* 'lisp) (progn (pp-init start-column) (if (com-cell-p clause) (lsyn-comment-printer clause pp-currentpos* (1+ (first pp-istack*)) ; indent column t ; clause-p ) (if (and (< (length clause) 3) (pp-fits clause)) (pp-small-clause clause) (pp-big-clause clause))) (if *comment-style* ;; converter is active ==> return current col., (1+ pp-currentpos*) (progn (pp-newline) t) ))) ((eq *style* 'xml) (pp-rfml-clause clause)) ) ) (defun pp-small-clause (c) (pp-expr c)) (defun pp-big-clause (c) (pp-expr '|(|) (pp-expr (car c)) (pp-expr '| |) (pp-expr (cadr c)) (if (> (length c) 2) (pp-newline)) (do ((item (cddr c) (cdr item))) ((null item)) (pp-expr '| |) (pp-expr (car item)) (if (not (null (cdr item))) (pp-newline))) (pp-expr '| )|)) (defun pp-expr (*expr) (when (eq 'comment-was-here (first pp-stack*)) ; comment printed ? (pp-pop pp-stack*) ) (cond ((consp *expr) (cond ((vari-t *expr) (pp-vari *expr)) ((inst-t *expr) (pp-list (cdr *expr) '|`| '||)) ((uninst-t *expr) (pp-list (cdr *expr) '|,| '||)) ; ((cut-t *expr) ; (pp-list (cdr *expr) '|!| '||)) ((ecal-t *expr) (pp-list (cdr *expr) '|@| '||)) ((typ-t *expr) (pp-list (cdr *expr) '|$| '||)) ((is-t *expr) (pp-list *expr '|(| '|)|)) (t (pp-list *expr '|(| '|)|)))) ((com-cell-p *expr) (lsyn-comment-printer *expr pp-currentpos* (1+ (first pp-istack*)) ; indent column )) (t (pp-prin *expr)))) (defun pp-list (*expr pre post) (if (pp-fits *expr) (pp-flat-list *expr pre post) (pp-broken-list *expr pre post))) (defun pp-flat-list (*expr pre post) (pp-prin pre) (do ((item *expr (cdr item))) ((null item)) (pp-expr (car item)) (if (not (null (cdr item))) (pp-prin '| |))) (pp-prin post)) (defun pp-broken-list (*expr pre post) (pp-start pre) (pp-pushmargin) (do ((item *expr (cdr item))) ((null item)) (pp-expr (car item)) (if (not (null (cdr item))) (pp-newline))) (pp-popmargin) (pp-finish post)) (defun pp-vari (x) (pp-expr (variable-name x))) (defun pp-start (pre) (pp-prin pre) (pp-push ")" pp-stack*)) (defun pp-finish (post) (cond ((eq 'comment-was-here (pp-top pp-stack*)) ;; print on fresh line because last item was a comment: (setq pp-currentpos* (pp-top pp-istack*)) (pro-newline-and-indent (1+ pp-currentpos*)) (pp-pop pp-stack*) (unless (equal ")" (pp-top pp-stack*)) (pp-pop pp-stack*) ) (pp-pop pp-stack*) ) ((equal ")" (pp-top pp-stack*)) ;; pre was on same line ==> don't print a blank: (pp-pop pp-stack*) ) ((equal " " (pp-top pp-stack*)) ;; pre was not on same line ==> print a blank (pp-pop pp-stack*) (pp-pop pp-stack*) (pp-prin '| |) )) (pp-prin post) ) (defun pp-pushmargin() (pp-push pp-currentpos* pp-istack*)) (defun pp-popmargin () (pp-pop pp-istack*)) (defun pp-newline () (if (equal ")" (pp-top pp-stack*)) (pp-push " " pp-stack*)) (rf-terpri) (spaces (pp-top pp-istack*)) (setq pp-currentpos* (pp-top pp-istack*))) (defun pp-prin (*expr) (cond ((characterp *expr) ; support printing of characters (if (graphic-char-p *expr) (progn ; #\ (setq pp-currentpos* (+ pp-currentpos* (flatsize *expr))) (rf-format "~s" *expr)) ; #/ (let ((str (format nil "#/~d" (char-code *expr)))) (setq pp-currentpos* (+ pp-currentpos* (flatc str))) (rf-princ-like-lisp str)))) ((rfi-special-symbolp *expr) (setq pp-currentpos* (+ pp-currentpos* (flatc *expr))) (rf-princ *expr)) (t (setq pp-currentpos* (+ pp-currentpos* (flatsize *expr))) (rf-princ *expr)))) (defun pp-top (*stack) (car *stack)) (defun spaces (n) (dotimes (x n) (rf-princ '| |))) (defun flatc (*expr) (length (princ-to-string *expr))) (defun pp-fits (expr) (< (+ pp-currentpos* (flatsize expr)) *rf-print-width*)) (defun flatsize (*expr) (length (prin1-to-string *expr))) ;;;### eof ;;;### File "printer.lisp" (defun rfi-cmd-print-width (userline) (cond ((= 1 (length userline)) (rf-princ-like-lisp *rf-print-width*) ) ((numberp (second userline)) (setq *rf-print-width* (second userline)) ) (t (rf-princ-like-lisp "Error: Number expected.") ))) ; ----------------------------------------------------------------------------- ; ; print-routines for rfi: ; ; rf-print, rf-princ, rf-terpri, rf-fresh-line, rf-pprint, ; rf-pprint-db, rf-pprint-spy ; ; ----------------------------------------------------------------------------- (defun rf-print (x) (rf-fresh-line) (rf-princ x)) (defun rf-princ-like-lisp (x) ; prints x using princ. (if (rfi-script-mode-p) (princ x *rfi-script-output*) ) (princ x *rfi-standard-output*) ) (defun rf-princ (x) (if (rfi-script-mode-p) (rf-princ-1 x *rfi-script-output*)) (rf-princ-1 x *rfi-standard-output*)) (defun rf-princ-1 (x stream) (let ((*print-case* :downcase)) (if (rfi-special-symbolp x) (princ x stream) (prin1 x stream)))) (defun rf-format (&rest args) (when (rfi-script-mode-p) (apply #'format (cons *rfi-script-output* args))) (apply #'format (cons *rfi-standard-output* args))) (defun rf-terpri () (if (rfi-script-mode-p) (terpri *rfi-script-output*)) (terpri *rfi-standard-output*) t) (defun rf-fresh-line () (if (rfi-script-mode-p) (fresh-line *rfi-script-output*)) (fresh-line *rfi-standard-output*)) (defun rf-pprint-db (db) (cond ((listp db) (do ((clauselist db (cdr clauselist))) ((endp clauselist)) (cond ((listp (car clauselist)) (rf-pprint-clause (car clauselist))) (T (rf-error "(rf-pprint-db): " (format nil "~A" (car clauselist)) " clause isn't a list"))))) (T (rf-error "(rf-pprint-db): " (format nil "~A" db) " database isn't a list")))) (defun rf-pprint-clause (c) (pp-clause (normalize-expr c))) (defun rf-pprint (x) (pp (normalize-expr x)) x) (defun pretty-print (x) (rf-pprint (mk-inst x)) x) (defun rf-pprint-spy (x) ; (rf-terpri) (let ((l (1- (length x)))) (cond ((or (= 0 *rfi-showdepth*) (>= *rfi-showdepth* l)) (pp (normalize-expr x))) (t (pp (normalize-expr (append (butlast x (- l *rfi-showdepth*)) (list (intern (make-string (- l *rfi-showdepth*) :initial-element #\*)))))))))) ; ----------------------------------------------------------------------------- ; ; listing-function ; ; ----------------------------------------------------------------------------- (defun rfi-cmd-l (x db &optional ll-db) (when *tcl* (format t "~a{Listing:~%" *esc*)) (cond ((null x) (rf-pprint-db db)) ((atom x) (rfi-cmd-l-1 (mk-pairpattern x 'id) db)) (t (rfi-cmd-l-1 x db))) (let ((*print-pretty* t) ; ll-db (*print-case* :downcase)) (mapcar #'(lambda (fct) (when (or (null x) (eq x (caadr fct))) (rf-terpri) (rf-print (caddr fct)) (rf-terpri) (rf-pprint-db (cdddr fct)))) ll-db)) (when *tcl* (format t "~a}" *esc*))) (defun rfi-cmd-l-1 (pattern database) (let* ((clause (car database)) (head (subst (gentemp) ; one-sided unification 'vari ; simulated with gentemp-terms (s-conclusion clause)))) (cond ((null database) t) ((unify pattern head '((bottom))) (rf-pprint-clause clause) (rfi-cmd-l-1 pattern (cdr database))) (t (rfi-cmd-l-1 pattern (cdr database)))))) ; --------------------------------------------------------------------------- ; ; define length of spy-trace: showdepth ; ; --------------------------------------------------------------------------- (defun rfi-cmd-showdepth (userline) (cond ((cadr userline) (if (numberp (cadr userline)) (setq *rfi-showdepth* (cadr userline)) (rf-error "(rfi-cmd-showdepth): " (format nil "~A" (cadr userline)) " a number is needed!"))) (t (rf-print '|actual showdepth: |) (rf-princ *rfi-showdepth*)))) ; --------------------------------------------------------------------------- ; ; normalizing lists: no more (rfi-)dotted pairs ; ; --------------------------------------------------------------------------- (defun normalize-expr (x) (cond ((atom x) x) ((rfi-dotted-pair-p x) (list (normalize-expr (car x)) '|.| (normalize-expr (cdr x)))) (t (cons (normalize-expr (car x)) (normalize-expr (cdr x)))))) (defun rfi-atom (a) (or (atom a) (rfi-quasi-atom a))) (defun rfi-quasi-atom (a) (or (inst-tt a) (uninst-tt a) (vari-tt a) ;(cut-tt a) (ecal-tt a) (typ-tt a) (is-tt a))) (defun rfi-dotted-pair-p (l) (or (and (listp l) (= 1 (length l)) (not (null (cdr l)))) (rfi-quasi-atom (cdr l)))) (defun rfi-special-symbolp (x) (and (not (stringp x)) (not (equal (princ-to-string x) (prin1-to-string x))))) ;;;### eof ;;;### File "emulint.lisp" ; ----------------------------------------------------------------------------- ; ; calling emulator-functions ; ; ----------------------------------------------------------------------------- (defun rfi-cmd-emul (userline) "userline = (emul) userline = (emul --nocopy) " ;; automatization a la speedup-check's *speedup-copy* pointer comparison ;; not used because of compiler-internal horizontal transformations (when (emulator-available-p) (cond ((null (cdr userline)) (setq *rfi-database* (mod-flatten-databases)) (save-original-source *rfi-database*) ; MS 3/96 (rfi-set-emulator-mode) ) ((eq '--nocopy (second userline)) (rf-princ-like-lisp "Database of compiler is not changed.") (rfi-set-emulator-mode) ) (t (rf-format "~A~%~A~%~A~%~A~%" "Error: Unknown option of command emul." " Use one of:" " emul" " emul --nocopy" ))))) ; command is meaningful only if emulate is defined (emulator is loaded) (defun emulator-available-p () (cond ((fboundp 'emulate) t) (t (rf-error "(rfi-cmd-emul): emulator not available!") nil))) (defun rfi-cmd-inter () (rfi-set-interpreter-mode)) (defun rfi-cmd-emuc () (setq *rfi-database* (mod-flatten-databases)) (rfi-set-emuc-mode)) (defun rfi-cmd-listclass (userline) (if (emulator-available-p) (let ((*style* 'lisp)) ; always use Lisp-syntax (list-class (cadr userline))))) (defun rfi-cmd-listcode (userline) (if (emulator-available-p) (let ((*style* 'lisp)) ; always use Lisp-syntax (list-code (cadr userline))))) (defun rfi-cmd-compile (userline) (if (emulator-available-p) (loco (select-clauses-of (cadr userline))))) (defun rfi-cmd-classify (db) (if (emulator-available-p) (progn (setq *predicates* nil) (read-db db) ; select-clauses-of db presupposed (setq *classified-database* (classify-db *predicates*))))) (defun rfi-cmd-codegen () (if (emulator-available-p) (progn (mapcar #'(lambda (x) (append (mapcan2 #'(lambda (y) (icg.mk-header y (s-cg-arity-of-proc x))) (iif.mk-tree x)) (code-gen-proc x))) *classified-database*) (if (rfi-emuc-mode-p) (list-code-to-file *ic*))))) (defun select-clauses-of (procedurename) (cond ((null procedurename) *rfi-database*) (t (select-clauses-of-1 procedurename *rfi-database*)))) (defun select-clauses-of-1 (procedurename db) (cond ((null db) nil) ((eq procedurename (car (s-conclusion (car db)))) (cons (car db) (select-clauses-of-1 procedurename (cdr db)))) (t (select-clauses-of-1 procedurename (cdr db))))) (defun rfi-cmd-quitwam () "terminates the RAWAM process" (emuc-quit)) (defvar *rf-style*) ; used to restore RELFUN style (defun rfi-cmd-ll () (setq *rf-style* *style*) (setq*style* 'lisp) (setq gasm.*default-unknown-label* ll.*unknown-label*) (setq gasm.*default-module* 'lluser) (setq*rfi-machine* 'll) (setq *rfi-prompt* '|ll> |)) ; ----------------------------------------------------------------------------- ; ; preparing the query for the emulator ; ; - generate something like (ft (main _x1 .._xn) (p1 ...) ... (pm ...)) ; - bindings of _x1 through _xn should be displayed ; - database and query must be "flatter" for emulator ; - inst is removed because not active structures are allowed and so everyting ; is passiv ; ; ----------------------------------------------------------------------------- (defun transform-query-for-emulator (userline) (let ((uservars (delete-duplicates (finduservars userline) :test #'equal))) (cdr (normalize-foot (deanon-clause (flatten-struc-clause (cons 'ft (tuptocons1 (maingen uservars (uncomma/body (hotrans/body (unlambda/body (unor/body (unmacro/body (untype/body (orf2/body userline)))))))))))))))) (defun normalize-foot (clause) ; foot must not be an is-call! (let ((foot (car (last clause)))) (if (is-t foot) (append clause (list (mk-inst (s-patt-is foot)))) clause))) (defun maingen (uservars callist) (cons (cons 'main uservars) callist)) (defun finduservars (callist) (cond ((null callist) nil) ((atom callist) nil) ((vari-t callist) (list callist)) (t (append (finduservars (car callist)) (finduservars (cdr callist)))))) ;;;### eof ;;;### File "absynt.lisp" ; TERMS ; for terms with functor func we use standard predicate names coming in ; raw (func-t for "func term") and often ; fine (func-tt for "func term emphasized") versions ; Constants ; predicates: atom (from LISP) ; constructors: none ; selectors: none ; Variables (named) ; predicates: (defun vari-t (x) (and (consp x) (eq 'vari (car x)))) (defun vari-tt (x) (and (vari-t x) (or (= 2 (length x)) (= 3 (length x))))) (defun varivari-t (term) (and (vari-t term) (vari-t (cadr term)))) ; bnd coding ; constructors: list (currently from LISP) ; selectors: (defun name-of (var) (read-from-string (symbol-name (cadr var)))) (defun level-of (var) (cond ((null (cddr var)) nil) (t (caddr var)))) ; transformer (term structure to print image): (defun variable-name (variableterm) (intern (concatenate 'string "_" (princ-to-string (name-of variableterm)) (if (level-of variableterm) (concatenate 'string "*" (princ-to-string (level-of variableterm))) "")))) ; Variables (anonymous) ; predicates: (defun anonymous-p (x) (eq x 'id)) ; "id"-alternatives? PROLOG-like syntax: "_" ; constructors: 'id (currently from LISP) ; selectors: none ; Instructures (instantiated structures, incl. tuples/lists) ; predicates: (defun inst-t (x) (and (consp x) (eq 'inst (car x)))) (defun inst-tt (x) (and (inst-t x) (= 2 (length x)))) ; constructors: (defun mkk-inst (term) (list 'inst term)) (defun mk-inst (term) (cond ((or (atom term) (vari-t term) (typ-t term)) term) (t (list 'inst term)))) ; selectors: (defun un-inst (x) (cond ((inst-t x) (cadr x)) (t x))) (defun de-inst (x) (cond ((atom x) x) ((inst-t x) (cadr x)) (t (cons (de-inst (car x)) (de-inst (cdr x)))))) ; Eforcers (evalulation forcers within instructures, like LISP's comma macros) ; predicates: (defun uninst-t (x) (and (consp x) (eq 'uninst (car x)))) (defun uninst-tt (x) (and (uninst-t x) (= 2 (length x)))) ; constructors: cons/list (currently from LISP) ; selectors: car/cdr (currently from LISP) ; Rests (varying-length rests of structures, incl. tuples/lists) ; predicates: (defun bar-t (x) (and (consp x) (eq '\| (car x)))) ; constructors: cons/list (currently from LISP) ; selectors: car/cdr (currently from LISP) ; Domains ; predicates: (defun dom-t (x) (and (consp x) (eq 'dom (car x)))) ; constructors: (defun mk-dom (elist) (cond ((null elist) nil) ((null (cdr elist)) (car elist)) (t (cons 'dom elist)))) ; selectors: car/cdr (currently from LISP) ; Exclusions ; predicates: (defun exc-t (x) (and (consp x) (eq 'exc (car x)))) ; constructors: (defun mk-exc (elist) (cond ((null elist) 'id) (t (cons 'exc elist)))) ; selectors: car/cdr (currently from LISP) ; Sorts ; predicates: (defun typ-t (x) (and (consp x) (eq 'typ (car x)))) (defun typ-tt (x) (and (typ-t x) (= 2 (length x)))) ; constructors: (defun mk-type (sort-name) ; only called in ub-sortbase-glb (when sort-name ; nil signals empty intersection: do not use as sort name! (and (atom sort-name) (list 'typ sort-name)))) ; selectors: (defun s-type (arg) (and (typ-t arg) (cadr arg))) ; Binders ; predicates: (defun bnd-t (x) (and (consp x) (eq 'bnd (car x)))) ; constructors: (defun mk-bnd (variable expr) (list 'bnd variable expr)) ; selectors: (defun s-variable-bnd (bndterm) (cadr bndterm)) (defun variable-if-bnd (term) (and (bnd-t term) (s-variable-bnd term))) (defun s-expr-bnd (bndterm) (caddr bndterm)) (defun un-bnd (term) (cond ((bnd-t term) (s-expr-bnd term)) (t term))) (defun de-bnd (x) (cond ((atom x) x) ((bnd-t x) (s-expr-bnd x)) (t (cons (de-bnd (car x)) (de-bnd (cdr x)))))) ; Typed expressions (":"-infix like "bnd"-prefix, but also usable actively) ;; connection with "bnd" (PROLOG-like syntax: ":") and "is" should be clarified ; predicates: (defun typed-expr-t (item) ;; should be named "typed-expr-p" (and (consp item) (consp (cdr item)) (eq (second item) '\:) )) ; constructors: (defun mk-typed-expr (term type) (list term '\: type)) ; selectors: (defun typed-expr-term (triple) (first triple) ) (defun typed-expr-type (triple) (third triple) ) ; Generic term predicates (defun typexcdom-p (term) (or (dom-t term) (exc-t term) (typ-t term))) (defun convar-p (term) (or (atom term) (vari-t term) (typ-t term))) (defun final-p (term) (or (atom term) (inst-t term) (vari-t term) (typ-t term))) (defun flat-p (term) (cond ((final-p term) t) ((or (is-tt term) (ecal-t (cdr term))) nil) ((final-p (car term)) (flat-p (cdr term))))) (defun flat-struc-p (term) (cond ((convar-p term) t) ((and (inst-t term) (flat-struc-p (cadr term))) t) ((or (is-tt term) (ecal-t (cdr term))) nil) ((convar-p (car term)) (flat-struc-p (cdr term))))) ; STRUCTURES/EXPRESSIONS ; Tuples (embedded tup structure OR tup expression, analoguous to LISP's list) ; predicates: (defun tup-t (x) (and (consp x) (eq 'tup (car x)))) ; constructors: cons/list (currently from LISP) ; selectors: car/cdr (currently from LISP) ; Conses (binary cns structure OR active cns expression, produced by untup) ; predicates: (defun cns-t (x) (and (consp x) (eq 'cns (car x)))) ; constructors: list (currently from LISP) ; selectors: car/cdr (currently from LISP) ; EXPRESSIONS ; Is-assignments ; predicates: (defun is-t (x) (and (consp x) (eq 'is (car x)))) (defun is-tt (x) (and (is-t x) (= 3 (length x)))) (defun convar-is-p (term) (and (is-t term) (convar-p (s-expr-is term)))) (defun final-is-p (term) (and (is-t term) (final-p (s-expr-is term)))) (defun flat-is-p (term) (and (is-t term) (flat-p (s-expr-is term)))) (defun flat-struc-is-p (term) (and (is-t term) (flat-struc-p (s-expr-is term)))) ; constructors: (defun mk-is (patt expr) (list 'is patt expr)) (defun gen-is (term goal) (cond ((is-t term) (mk-is (s-patt-is term) goal)) (t goal))) ; selectors: (defun s-patt-is (isterm) (cadr isterm)) (defun s-expr-is (isterm) (caddr isterm)) (defun un-is (term) (cond ((is-t term) (s-expr-is term)) (t term))) ; Multiple is-assignments ; predicates: (defun final-mis-p (term) (and (is-t term) (final-p (s-expr-mis term)))) ; constructors: none ; selectors: (defun s-patt-mis (isterm) (let ((amptail (member '& isterm))) (cond (amptail (cdr (ldiff isterm amptail))) (t (list (cadr isterm)))))) (defun s-expr-mis (isterm) (car (last isterm))) ; Non-stricts (defun naf-ground-p (x) ; the argument of naf must be ground (cond ((or (atom x) (inst-t x)) t) ((vari-t x) nil) ; (naf (is _x 1)) (is _x 2) wrongly failing if ((is-tt x) (naf-ground-p (s-expr-is x))) (t (and (naf-ground-p (car x)) (naf-ground-p (cdr x)))))) (defun naf-inversion (x) (cond ((null x) t) ((eq x 'false) t) (t nil))) ; predicates: (defun tupof-t (x) (and (consp x) (eq 'tupof (car x)))) (defun once-t (x) (and (consp x) (eq 'once (car x)))) (defun naf-t (x) (and (consp x) (eq 'naf (car x)))) (defun nonstrict-p (term) (or (tupof-t term) (once-t term) (naf-t term))) ; constructors: cons/list (currently from LISP) ; selectors: (defun s-conj-tupof (tupofterm) (cdr tupofterm)) (defun s-conj-once (onceterm) (cdr onceterm)) (defun s-conj-naf (nafterm) (cdr nafterm)) ; Eval-call ; predicates: (defun ecal-t (x) (and (consp x) (eq 'ecal (car x)))) (defun ecal-tt (x) (and (ecal-t x) (= 2 (length x)))) ; constructors: cons/list (currently from LISP) ; selectors: car/cdr (currently from LISP) ; Clause (builtin) ; predicates: (defun clause-t (x) (and (consp x) (eq 'clause (car x)))) ; constructors: cons/list (currently from LISP) ; selectors: (defun s-clause (clauseterm) (cadr clauseterm)) ; CLAUSES ; Valued clauses (generic for hornish and footed clauses) ; predicates: ;(defun cut-t (x) (and (consp x) (eq 'cut (car x)))) ;(defun cut-tt (x) (and (cut-t x) (= 2 (length x)))) ;(defun cut-p (clause) ; (and (consp clause) ; (cut-t (s-head clause)))) ; constructors: cons/list (currently from LISP) (defun mk-pairpattern (x y) (list x '\| y)) ; this has changed since bars are used instead of dots ; selectors: (defun s-kind (clause) (car clause)) (defun s-premises ; for hornish clauses the premises constitute the entire body (clause) (cddr clause)) (defun s-head (clause) (cadr clause)) (defun s-conclusion (clause) (cond ;((cut-p clause) (cadr (s-head clause))) (t (s-head clause)))) ; Hornish clauses ; predicates: (defun hn-t (x) (and (consp x) (eq 'hn (car x)))) (defun hn-tt (x) (and (hn-t x) (< 1 (length x)))) ; constructors: cons/list (currently from LISP) ; selectors: see valued clauses ; Footed clauses ; predicates: (defun ft-t (x) (and (consp x) (eq 'ft (car x)))) (defun ft-tt (x) (and (ft-t x) (< 2 (length x)))) ; constructors: cons/list (currently from LISP) (defun mk-premises (body foot) (append body (list foot))) ; selectors: (defun s-body (clause) (butlast (cddr clause))) (defun s-foot (clause) (car (last (cddr clause)))) ; Multi-footed clauses ; predicates: none ; constructors: none ; selectors: (defun s-mbody (clause) (let ((amptail (member '& (cddr clause)))) (cond (amptail (ldiff (cddr clause) amptail)) (t (butlast (cddr clause)))))) (defun s-mfoot (clause) (let ((amptail (member '& (cddr clause)))) (cond (amptail (cdr amptail)) (t (last (cddr clause)))))) ; Uncertainty clauses ; predicates: ; An uncertainty rule has the form ; (uc (c...) (ucfb1...) .. (ucfbM ...) UC-FACTOR) ; the premises being functional and returning ; uncertainty values, normally factors in the interval [0 .. 1] (defun uc-t (x) (and (consp x) (eq 'uc (car x)))) (defun uc-tt (x) (and (uc-t x) (> (length x) 2))) ; An uncertainty fact has the form ; (uc (c...) UC-FACTOR) (defun ucfact-t (clause) ;; should be named "ucfact-p" (and (uc-tt clause) (= (length clause) 3))) ; constructors: cons/list (currently from LISP) ; selectors: car/cdr (currently from LISP) ; KNOWLEDGE BASES ; Databases ; predicates: none (currently ordinary LISP lists) ; constructors: cons/list (currently from LISP) ; selectors: (defun s-first-db (database) (car database)) (defun s-rest-db (database) (cdr database)) ;;;### eof ;;;### File "lispexec.lisp" ; ----------------------------------------------------------------------------- ; ; calling lisp-functions from rfi ; ; ----------------------------------------------------------------------------- (defun lisp-exec (unisgoal environ) (let ((ultinstargs (ultimate-instant (de-inst (cdr unisgoal)) environ))) (cond ((lisp-extra-p (car unisgoal)) ; structures must e.g. be printable (mk-inst (apply (symbol-function (car unisgoal)) ultinstargs))) ; sublevels remain untouched by built-ins -- check only arg toplevel: ((or (and (lisp-predicate-p (car unisgoal)) (not (some #'vari-t ultinstargs))) ; structures testable (every #'(lambda (x) (or (atom x) (cns-t x) (tup-t x))) ultinstargs)) (list-to-tup-false (apply (symbol-function (car unisgoal)) ultinstargs) (lisp-predicate-p (car unisgoal)))) (t (rf-error "(lisp-exec): " (format nil "~A" ultinstargs) " structure or free variable can't be arg to LISP builtin"))))) (defun lisp-builtin-p (operator) (or (lisp-function-p operator) (lisp-predicate-p operator) (lisp-extra-p operator))) (defun lisp-function-p (operator) (member operator *lisp-functions*)) (defun lisp-static-function-p (operator) (member operator *lisp-static-functions*)) (defun lisp-predicate-p (operator) (member operator *lisp-predicates*)) (defun lisp-extra-p (operator) (member operator *lisp-extras*)) ; defun-builtins: (defun wait (text) ; extra (rf-princ text) (read-char)) (defun err (arg text) ; extra (rf-error "(err): " (format nil "~A" arg) " " text)) ; RELFUN's list selector systematics ; visually clear analogues of LISPs first, second, ... (should be up to 9th): (defun 1th (x) ; pronounce "one-eth" (if (and (tup-t x) (cdr x)) (cadr x) (rf-error "(1th): " (format nil "~A" x) " selector needs long enough list arg"))) (defun 2th (x) ; pronounce "twoth" (if (and (tup-t x) (cdr x) (cddr x)) (caddr x) (rf-error "(2th): " (format nil "~A" x) " selector needs long enough list arg"))) ; ... and symmetrically from the back of lists (should be up to th9): (defun th1 (x) (if (and (tup-t x) (cdr x)) (car (last x)) (rf-error "(th1): " (format nil "~A" x) " selector needs long enough list arg"))) ; corresponding analogues of LISPs rest or cdr, cddr, ... (s.a.): (defun 1rest (x) ; pronounce "onerest" (if (and (tup-t x) (cdr x)) (cons 'tup (cddr x)) (rf-error "(1rest): " (format nil "~A" x) " selector needs long enough list arg"))) (defun 2rest (x) ; pronounce "tworest" (if (and (tup-t x) (cdr x) (cddr x)) (cons 'tup (cdddr x)) (rf-error "(2rest): " (format nil "~A" x) " selector needs long enough list arg"))) ; ... and symmetrically from the back of lists (s.a.): (defun rest1 (x) (if (and (tup-t x) (cdr x)) (butlast x) (rf-error "(rest1): " (format nil "~A" x) " selector needs long enough list arg"))) ; selectors complementary to 1rest, 2rest, ..., i.e. app(Dstart(l),Drest(l))=l: (defun 1start (x) (if (and (tup-t x) (cdr x)) (list 'tup (cadr x)) (rf-error "(1start): " (format nil "~A" x) " selector needs long enough list arg"))) (defun 2start (x) (if (and (tup-t x) (cdr x) (cddr x)) (list 'tup (cadr x) (caddr x)) (rf-error "(2start): " (format nil "~A" x) " selector needs long enough list arg"))) ; ... and symmetrically from the back of lists, i.e. app(restD(l),startD(l))=l: (defun start1 (x) (if (and (tup-t x) (cdr x)) (cons 'tup (last x)) (rf-error "(start1): " (format nil "~A" x) " selector needs long enough list arg"))) ; general nth[N], thn[N], nrest[N], restn[N], nstart[N], startn[N] ; selectors to be defined in prelude.rfp (defun len (x) (if (tup-t x) (length (cdr x)) (rf-error "(len): " (format nil "~A" x) " atom or structure can't be arg to list builtin"))) (defun app (x y) (if (and (tup-t x) (tup-t y)) (cons 'tup (append (cdr x) (cdr y))) (rf-error "(app): " (format nil "~A" (list x y)) " atom or structure can't be arg to list builtin"))) (defun operators () ; function "collect all rfi-database operator names" (cons 'tup (remove-duplicates (mapcar #'caadr (get-database))))) (defun date () ; function (multiple-value-bind (a b c d e f g h i) (get-decoded-time) (list 'tup d (nth (1- e) '(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec)) f c b))) ; handling of global variables (only used in interpreter) (defun setvar (var value) (set var value)) ; (eval (list 'setq var (list 'quote value)))) (defun getvar (var) (if (boundp var) (symbol-value var))) ; dynamic assert and retract /MC/HB/MS ; variable encapsulation in strings is preliminary ; syntax (system-provided ".") will change to user-provided "." (cf. toplevel) ; variable instantiation in hn and ft structures is done ; syntax SHOULD be like in programs, i.e. assertz(l(j,m).)->assertz(hn[l[j,m]]) (defun assertz (clause environ) (if (stringp clause) (rfi-command (handle-rfi-cmd 'az (concatenate 'string clause ".") nil)) (set-database (append (get-database) (list (un-rename-variables (ultimate-instant (un-inst clause) environ)))))) (speedup-init) clause) (defun retractx (clause environ) "can be used with embedded clause builtin like general retract" (if (stringp clause) (rfi-command (handle-rfi-cmd 'rx (concatenate 'string clause ".") nil)) (set-database (remove (un-rename-variables ; trivial use (no gentemp) (ultimate-instant (un-inst clause) environ)) (get-database) :test #'equal))) (speedup-init) clause) (defun un-rename-variables (term) (let* ((vars (remove-duplicates (collect-variables* term) :test #'equal)) (sorted-vars (sort vars #'vari<)) (ren-alist (build-ren-alist sorted-vars))) (sublis ren-alist term :test #'equal))) (defun build-ren-alist (sorted-vars) "associate level-indexed vars with level-less versions, preserving level differentiations by gentemp suffixes" (when sorted-vars (let ((var (car sorted-vars))) ; thanks to remove-duplicates (if (cdr sorted-vars) ; var, var2 cannot be equal (let ((var2 (cadr sorted-vars))) (if (eq (second var) (second var2)) ; non-final var in a (cons ; chain with eq names and different levels (cons var (list 'vari ; is gentemped (gentemp (string (second var))))) (build-ren-alist (cdr sorted-vars))) (cons ; final var just gets (cons var (list 'vari (second var))) ; level-less (build-ren-alist (cdr sorted-vars))))) (list (cons var (list 'vari (second var)))))))) (defun vari< (v1 v2) (or (string< (second v1) (second v2)) (and (eq (second v1) (second v2)) (level< (third v1) (third v2))))) (defun level< (l1 l2) (or (null l2) (and l1 (< l1 l2)))) ; format-to-string and format-to-string* (defun format-to-string (fmt &rest args) (apply #'format nil fmt args)) (defun format-to-string* (fmt args) ; for use in emulator (apply #'format nil fmt (cdr args))) ; cdr removes tup ;-------------- ;(Klaus 30.09.1990) (defun relfun-exec (unisgoal environ) (list-to-value-false (apply (symbol-function (car unisgoal)) (ultimate-instant (cdr unisgoal) environ)) t)) (defun list-to-value-false (x nil-to-false) (cond ((and (null x) nil-to-false) 'false) (t (mk-inst x)))) (defun relfun-builtin-p (operator) (or (relfun-extra-p operator))) (defun trueatom (x) "true, if only a Relfun atom and not nil" (and x (atom x))) (defun nontrueatom (x) (not (atom x))) (defun var (x) (vari-t x)) (defun nonvar (x) (not (vari-t x))) (defun relfun-extra-p (operator) (member operator *relfun-extras*)) ; Transforming between RELFUN tup/cns and LISP list/cons nestings ; (LISP builtins accept no non-tup/non-cns structures on any level) ; NO LONGER NEEDED: ;(defun tup-to-listargs(l) ; (mapcar #'tup-to-list l) ) ;(defun tup-to-list (x) ; (cond ((atom x) x) ; ((tup-t x) (mapcar #'tup-to-list (cdr x))) ; ((cns-t x) (cons (tup-to-list (cadr x)) (tup-to-list (caddr x)))) ; (t (rf-error "(tup-to-list): " ; (format nil "~A" x) ; " structure or free variable can't be arg to LISP builtin")))) ; NO LONGER NEEDED: ;(defun tup-to-list (x) ; sublevels remain untouched ; (cond((tup-t x) (cdr x)) ; ((cns-t x) (cons (cadr x) (caddr x))) ; (t x))) (defun list-to-tup-false (x nil-to-false) (cond ((and (null x) nil-to-false) 'false) #-CLiCC ((and (eq t x) nil-to-false) 'true) #+CLiCC ((and (or (eq t x) (eq #\T x)) nil-to-false) 'true) ; (t (mk-inst (list-to-tup x))))) ; SIMPLIFIABLE: (t (mk-inst x)))) ;(defun list-to-tup (x) ; (cond ((null x) '(tup)) ; ((final-p x) x) ; (t (cons 'tup (mapcar #'list-to-tup x))))) ; NO LONGER NEEDED: ;(defun list-to-tup (x) ; sublevels remain untouched ; (cond ((null x) '(tup)) ; ((final-p x) x) ; (t (cons 'tup x)))) ;;;### eof ;;;### File "reader.lisp" ; ----------------------------------------------------------------------------- ; ; changing the copy of lisp-readtable to accept rfi-syntax ; ; ----------------------------------------------------------------------------- (defmacro our-set-macro-character (a b c d) "Symbolics Lisp does not like FUNCTION but QUOTE to get the function associated with a symbol." #+genera `(set-macro-character ,a (quote ,b) ,c ,d) #-genera `(set-macro-character ,a (function ,b) ,c ,d) ) ;; Prolog-people like var-names with underscores (e.g. a_long_name), ;; but the current version of rfi.lsp when in Lisp-style can not read ;; the corresponding name (_a_long_name): (defun rfi-set-syntax nil ;; third arg. of set-macro-character: ;; nil ==> terminating macro-character ;; t ==> non-terminating macro-character (our-set-macro-character #\_ underscore-reader t *rfi-readtable*) (our-set-macro-character #\` backquote-reader nil *rfi-readtable*) (our-set-macro-character #\, comma-reader nil *rfi-readtable*) (our-set-macro-character #\$ dollar-reader nil *rfi-readtable*) (our-set-macro-character #\: colon-reader nil *rfi-readtable*) (our-set-macro-character #\@ ecal-reader nil *rfi-readtable*) ; (our-set-macro-character #\! cut-reader nil *rfi-readtable*) (our-set-macro-character #\| bar-reader nil *rfi-readtable*)) (defun underscore-reader (stream char) (declare (ignore char)) (let ((x (read stream t nil t))) (if (numberp x) (list 'vari (intern (princ-to-string x))) (list 'vari x)))) (defun backquote-reader (stream char) (declare (ignore char)) (list 'inst (read stream t nil t))) (defun ecal-reader (stream char) (declare (ignore char)) (list 'ecal (read stream t nil t))) ;(defun cut-reader (stream char) ; (declare (ignore char)) ; (list 'cut (read stream t nil t))) (defun bar-reader (stream char) (declare (ignore stream char)) '\|) (defun comma-reader (stream char) (declare (ignore char)) (list 'uninst (read stream t nil t))) (defun dollar-reader (stream char) (declare (ignore char)) (list 'typ (read stream t nil t))) (defun colon-reader (stream char) ; atom-reading ":" followed by " ": M.S.! (declare (ignore char)) (let ((next-char (read-char stream t nil t))) (cond ((and (graphic-char-p next-char) (char/= next-char #\ )) (unread-char next-char stream) (car (multiple-value-list (read-from-string-std (format nil ":~a" (read stream t nil t)))))) (t '\:)))) (defun read-from-string-std (string) (let ((*readtable* (copy-readtable nil))) (read-from-string string))) ; normalen Syntax wiederherstellen (defun rfi-reset-syntax nil (setq *readtable* (copy-readtable nil))) ; ----------------------------------------------------------------------------- ; ; input-function for rfi ; ; adapted from Lisplog file "specials.commonlisp.l" ; ; ----------------------------------------------------------------------------- ; The caller of readl detects no difference between the two syntaxes, ; because readl always returns an expression in Lisp-like syntax. ; This is the most important point to interface pro2lisp.lsp: (defun readl nil ; Reads input from the user. ; If prolog-style is active then the input is transformed to ; lisp-syntax. (let ((usercmd nil)) (loop (setq usercmd (rf-reader)) (cond ((equal usercmd "")) ; read again ((eq *style* 'lisp) (return (transform-string-to-single-lisp-object usercmd)) ) ; style is prolog: (t (let* ((pair (pro-split-input usercmd)) (rfi-cmd-as-symbol (car pair)) (rest-of-input-as-string (cdr pair)) (rfi-cmd-p (member rfi-cmd-as-symbol *rfi-commands* :test #'equal )) ) (cond ((null pair)) ; scanner signals error, read again (rfi-cmd-p (return (handle-rfi-cmd rfi-cmd-as-symbol rest-of-input-as-string usercmd ))) ;; transform Prolog-syntax to Lisp-syntax: (t (let ((input-as-list (pro-read-goal usercmd))) (if (not (null input-as-list)) ; error at transform. ? (return input-as-list) )))))))))) ; no (defun transform-string-to-single-lisp-object (s) ; guess (or look at the name) (let ((*readtable* *rfi-readtable*)) (read-from-string (concatenate 'string "(" s ")")))) (defun check-input-line (str &key (signal-error-p t)) "Checks if str is a well-formed input string (e.g. no 'negative' parentheses: nowhere in str can there be more closing than opening parentheses). Returns a list: (symbol str-wo-comments error-string). Where symbol is one of: {error, ready, continuable} str-wo-comments is str with all comments removed. error-string contains a string describing the error or the empty string. If signal-error-p is T an error-message is printed. Possible improvement: tolerate negative parentheses at the end of str." (let ((escape-p nil) (in-string-p nil) (dot-p nil) (len-of-str (length str)) (error-p nil) (error-msg "") (parentheses 0) (brackets 0) (str-wo-comments "") (comment-lead-in (if (eq *style* 'lisp) #\; #\%)) ) (do ((i 0 (1+ i)) (in-comment-p nil) (ch) ) ((or (= i len-of-str) error-p )) (setq ch (char str i) dot-p (or (char= #\. ch) (and dot-p (char= #\Space ch)) )) (cond (in-comment-p (setq in-comment-p (char/= #\Newline ch)) ) (escape-p (setq escape-p nil) ) (in-string-p (case ch (#\" (setq in-string-p nil)) (#\\ (setq escape-p t)) (#\Newline (setq error-p t error-msg "Newline in string") ) (t ))) (t (case ch (#\\ (setq escape-p t)) (#\" (setq in-string-p t)) (#\( (incf parentheses)) (#\) (decf parentheses) (when (< parentheses 0) (setq error-p t error-msg "Too many ')'" ))) (#\[ (incf brackets)) (#\] (decf brackets) (when (< brackets 0) (setq error-p t error-msg "Too many ']'" ))) (t (setq in-comment-p (char= comment-lead-in ch)) )))) (unless in-comment-p (setq str-wo-comments (concatenate 'string str-wo-comments (string ch))) )) (cond ((and (not error-p) in-string-p ) (setq error-p t error-msg "Unmatched '\"' at end of line" )) ((and dot-p (not (zerop parentheses))) (setq error-p t error-msg "Unmatched '(' at end of clause" ) ) ((and dot-p (not (zerop brackets))) (setq error-p t error-msg "Unmatched '[' at end of clause" )) ) (if error-p (if signal-error-p (progn (rf-format "Error in input line: ~A~%" error-msg) ;;(throw :toploop (readl)) (list 'error str-wo-comments error-msg) ) (list 'error str-wo-comments error-msg)) ;; no error: (if (and (zerop parentheses) (zerop brackets) (or (eq *style* 'lisp) (pro-complete-cmd-p str-wo-comments) )) (list 'ready str-wo-comments "") (list 'continuable str-wo-comments "") )))) (defun rf-reader () ; returns a string. ;; If prolog-style then multiple lines are separated by #\Newline. (do* ((line (rf-readline t) (rf-readline nil)) (cmd line (if (string/= "" cmd) (concatenate 'string cmd (string #\Newline) line) line )) ;; triple = (status line-wo-comments error-msg): (triple (check-input-line cmd) (check-input-line cmd)) ) ((member (first triple) '(ready error)) (case (first triple) (ready (second triple)) (error (rf-reader) ) (t (error "Internal error in rf-reader.")) )))) (defun rf-readline (firsttime) (cond ; ; normal input ; ((and (not (rfi-batch-mode-p)) (not (rfi-script-mode-p))) (read-from-terminal firsttime)) ; ; protocoll to script-file ; ((and (not (rfi-batch-mode-p)) (rfi-script-mode-p)) (let ((inputline (read-from-terminal firsttime))) (cond ((and firsttime (equal inputline "endscript")) (rfi-cmd-endscript) "") (t (if firsttime (progn (fresh-line *rfi-script-output*) (princ *rfi-prompt* *rfi-script-output*))) (princ inputline *rfi-script-output*) (terpri *rfi-script-output*) inputline)))) ; ; get input form batch-file ; ((and (rfi-batch-mode-p) (not (rfi-script-mode-p))) (let ((inputline (read-from-batch-file))) (cond ((and firsttime (equal inputline "end-of-batch-file")) ;(rfi-cmd-endexecute) "bye") (t (if firsttime (progn (fresh-line *rfi-standard-output*) (princ *rfi-prompt* *rfi-standard-output*))) (princ inputline *rfi-standard-output*) (terpri *rfi-standard-output*) inputline)))) ; ; get input from batch-file and protocoll to script-file ; ((and (rfi-batch-mode-p) (rfi-script-mode-p)) (let ((inputline (read-from-batch-file))) (cond (firsttime (cond ((equal inputline "end-of-batch-file") ;(rfi-cmd-endexecute) "bye") ((equal inputline "endscript") (fresh-line *rfi-standard-output*) (princ *rfi-prompt* *rfi-standard-output*) (princ inputline *rfi-standard-output*) (terpri *rfi-standard-output*) (rfi-cmd-endscript) "") (t (fresh-line *rfi-standard-output*) (fresh-line *rfi-script-output*) (princ *rfi-prompt* *rfi-standard-output*) (princ *rfi-prompt* *rfi-script-output*) (princ inputline *rfi-standard-output*) (princ inputline *rfi-script-output*) (terpri *rfi-standard-output*) (terpri *rfi-script-output*) inputline))) (t (princ inputline *rfi-standard-output*) (princ inputline *rfi-script-output*) (terpri *rfi-standard-output*) (terpri *rfi-script-output*) inputline)))))) (defun read-from-batch-file () (read-line *rfi-script-input* nil "end-of-batch-file" nil)) (defun read-from-terminal (firsttime) (if firsttime (progn (fresh-line *rfi-standard-output*) (princ *rfi-prompt* *rfi-standard-output*)) (spaces (length (princ-to-string *rfi-prompt*))) ) (read-line *rfi-standard-input*) ) ; In Prolog-style commas and some other characters signal an uncompleted input. (defun pro-complete-cmd-p (cmd-as-str) "Commas and some other characters indicate an uncompleted input." (if (= 0 (length cmd-as-str)) t (do* ((i (1- (length cmd-as-str)) (1- i)) (ch (char cmd-as-str i) (char cmd-as-str i)) (cont-chars (list #\, #\& #\| #\- #\!)) ) ;; find non-whitespace: ((or (case (char cmd-as-str i) ((#\Space #\Newline #\Tab) nil ) (t t) ) (= i 0) ) (not (member ch cont-chars :test #'char=)) )))) (defun rfi-yes-or-no-p (x) (if (rfi-batch-mode-p) t (yes-or-no-p x))) ; Comment characters are style-dependent: (defun remove-remarks (x) ; Remark starts with a ";" or "%" (let* ((begin-of-comment-char (if (eq 'prolog *style*) #\% #\; )) (p (position begin-of-comment-char x))) (if p (subseq x 0 p) x))) ;;;### eof ;;;### File "timer.lisp" ; ----------------------------------------------------------------------------- ; ; Timing the RELFUN execution ; Michael Herfert ; ; ----------------------------------------------------------------------------- ; benchmarking RELFUN programs via LISP: (defun rfi-cmd-timermode (userline-as-list-of-symbols) (cond ((null (cdr userline-as-list-of-symbols)) (if *timermode* (rf-format "~A timermode is on." (get-comment-lead-in)) (rf-format "~A timermode is off." (get-comment-lead-in)) )) ((eq 'on (second userline-as-list-of-symbols)) (setq *timermode* t) (rf-format "~A timermode is on now." (get-comment-lead-in)) ) ((eq 'off (second userline-as-list-of-symbols)) (setq *timermode* nil) (rf-format "~A timermode is off now." (get-comment-lead-in)) ) (t (rf-format "~A timermode: use `on' or `off' as argument." (get-comment-lead-in) )))) (defun rf-timer-start () "Starts the system timer if timermode is active." (when *timermode* (timer-start 'rf-system :suppress-error-msg-p t) )) (defun rf-timer-stop () "Stops and prints the system timer if timermode is active." (when *timermode* (timer-print (timer-stop 'rf-system)) )) ; benchmarking LISP programs: (defun timer-init () "Initializes the timer stuff. Useful after abnormal exits." (setq *timers* nil) ) (defun timer-start (name &key suppress-error-msg-p ) "Starts a timer. Signals an error if there is already a timer ." (cond ((not (assoc name *timers*)) ;; is unused: (if (rfi-emuc-mode-p) (setq *timers* (acons name (get-internal-real-time) *timers*)) (setq *timers* (acons name (get-internal-run-time) *timers*))) ) (suppress-error-msg-p ;; is used, remove it (be careful with this option) (timer-stop name) (timer-start name) ) (t (error "timer-start: timer name already used.") ))) (defun timer-get (name) "Reads the time since the timer has been started. It does not stop the timer. The value is measured in interanl-time-units. Signals an error if is an unknown timer." (let* ((stop-time (if (rfi-emuc-mode-p) (get-internal-real-time) (get-internal-run-time))) (pair (assoc name *timers*))) (if pair (- stop-time (cdr pair)) (error "timer-get: unknown timer.") ))) (defun timer-stop (name) "Reads the time since the timer has been started, stops the timer and removes its name from the list of used timers. The value is measured in internal-time-units. Signals an error if is an unknown timer." (prog1 (timer-get name) (setq *timers* (remove name *timers* :key #'car)) )) (defun timer-print (internal-time-units) (rf-fresh-line) (rf-format "~A Internal run time: ~d ticks (= ~,6f sec) ~%" (if (eq 'lisp *style*) lsyn-comment-lead-in psyn-comment-lead-in) internal-time-units (/ internal-time-units internal-time-units-per-second) )) ;;;### eof ;;;### File "modules.lisp" ; ----------------------------------------------------------------------------- ; ; The module system ; Michael Herfert ; ; ----------------------------------------------------------------------------- (defvar *rfi-modules* nil "Modules available in memory. *rfi-modules* = (mod1 mod2 ..) mod1 = (name annotation list-of-sub-module-names filename list-of-items modified-p current-context) list-of-sub-module-names is the original context of the module, not yet used (usable for restoring the original context after changed current context). ") (defvar *system-modules* nil "List of default modules (e.g. prelude). *system-modules* = (name1 name2 ..) ") (defvar *current-module* nil "A symbol naming the current module. ") (defvar *module-directories* nil "Search path to find modules. List of strings. Each string ends with a slash. ") (defvar *module-level* 0 "Used for pretty-printing purposes when loading files. ") (defvar *mod-verbose-p* nil "<==> print status informatations." ) ;;; --------------------------------------------------------------------------- (defun mod-init () (setq *module-directories* (list "./" #+our-fs (namestring (our-fs:logdir-dir :modules)) #-our-fs "./modules/" ) *system-modules* '(sortbase ; taxonomic knowledge prelude ; predefined procedures tracebase ; tracer procedures ) *current-module* 'workspace ) (when (null *rfi-modules*) ;; first call of mod-init: create headers for system modules: (setq*rfi-modules* (cons (mk-module 'workspace nil nil nil nil) (mapcar #'(lambda (module) (mk-module module nil nil nil nil) ) *system-modules* )))) (mapc #'(lambda (module) (unless (or (member module *system-modules*) (eq module 'workspace) ) (rfi-cmd-mdestroy (list 'mdestroy module)))) (mod-get-modules) )) ;;; --------------------------------------------------------------------------- ;;; ;;; M o d u l e I / O ;;; ;;; --------------------------------------------------------------------------- (defun mod-reread-from-file (module full-filename) "Reads database from file. On entry module must exist in memory. Sub-modules are not reloaded if in memory. " (mod-load-module module :full-filename full-filename :reread-p t) ) (defun mod-read-from-file (module full-filename) "Reads a database from file. The database may contain sub-modules via symbol-facts. Loads also all sub-modules, if not already loaded. Side-effect on *rfi-modules*. module (maybe NIL) is used to generate a module-descriptor. Returns a module-descriptor. " (let* ((db (read-db-from-file full-filename)) (list-of-sub-list-of-clauses (mod-divide-db db)) (sub-modules (mapcar #'mod-sub-module (first list-of-sub-list-of-clauses) )) (clauses (second list-of-sub-list-of-clauses)) ) (incf *module-level*) (mapc #'(lambda (module) (mod-load-module module) ) sub-modules ) (decf *module-level*) (mk-module module ; name nil ; annotations sub-modules full-filename clauses ))) (defun mod-load-module (module &key full-filename (verbose t) lisp-variable reread-p) "Loads a module (incl. sub-modules) into memory if not already loaded. module has no extension. Side-effect on *rfi-modules*. Stops with error-message if module cannot be found. If lisp-variable is given the items are read into this variable (used e.g. for prelude). No value. " (let ((*print-case* :downcase)) (if (and (mod-exists-p module) (not reread-p) ) ;; is in memory, no reload: (when verbose (mod-spaces *module-level*) (rf-format "Module ~A is already in memory.~%" module )) ;; load the module: (let ((old-module-descriptor (mod-get-descriptor module)) (new-module-descriptor (mod-read-from-file module (or full-filename (mod-gen-filename module) )))) (if old-module-descriptor (progn (rf-format "Recreating module ~A~%" module) (nsubstitute new-module-descriptor old-module-descriptor *rfi-modules* :test #'(lambda (x y) (eq (car x) (car y)))) (mod-tcl-mforest) ) (progn (mod-spaces *module-level*) (rf-format "Creating module ~A~%" module) (setq*rfi-modules* (append *rfi-modules* (list new-module-descriptor)) ))) (when lisp-variable (set lisp-variable (mod-get-items module)) (mod-modify-descriptor module :items lisp-variable) ))))) (defun mod-save-module-and-sub-modules (module &key ask-if-exists-p) "Saves module and all of its submodules." (let* ((*print-case* :downcase) (flat-list-of-sub-modules (cons module (mod-flatten-context (mod-get-context module))) ) (list-of-filenames (mapcar #'(lambda (module) (mod-get-filename module :create-name-p t) ) flat-list-of-sub-modules )) ) (mapc #'(lambda (module filename) (if (mod-get-modified module) (mod-save-module module filename :ask-if-exists-p ask-if-exists-p ) (rf-format "~A is unchanged, no save.~%" module)) ) flat-list-of-sub-modules list-of-filenames ))) (defun mod-save-module (module filename &key ask-if-exists-p) "Saves module, but no submodules. Generates symbol-facts for the context. " (if ask-if-exists-p (if (probe-file filename) (if (yes-or-no-p (stringcat "File " (namestring filename) ;;(string module) " already exists - overwrite? ")) (mod-save-module-aux module filename) nil ) ;; does not exist: (mod-save-module-aux module filename) ) (mod-save-module-aux module filename) )) (defun mod-save-module-aux (module filename) (let ((*print-case* :downcase)) (when t ;*mod-verbose-p* (rf-format "Saving module ~A in file ~A ..~%" module filename )) (with-open-file (ofile filename :direction :output :if-exists :supersede) (let ((*rfi-script-output* nil) (*rfi-standard-output* ofile) (db (append (mapcar #'mod-mk-sub-module (mod-get-context module) ) (mod-get-list-of-items module) )) ) ;;(print db) (mod-modify-descriptor module :modified nil) (rf-pprint-db db) (fresh-line ofile))))) ;;; ------------------------------------------------------------------------- (defun mod-flatten-context (context) "Returns a flat list of module names" (remove-duplicates (mod-flatten-context-aux context) :from-end t) ) (defun mod-flatten-context-aux (sym-or-list) "Returns a flat list of module-names possibly containing duplicates." (cond ((null sym-or-list) nil ) ((symbolp sym-or-list) (cons sym-or-list (mod-flatten-context-aux (mod-get-context sym-or-list))) ) (t (mod-append (mapcar #'mod-flatten-context-aux sym-or-list)) ))) (defun mod-collect-databases (&key reduced-sys-modules-p verbose-p) "Returns a list of all databases of the current context." ;; future: global variable !!! [hb] (let ((*print-case* :downcase) (list-of-module-names (remove-duplicates (append (if reduced-sys-modules-p ;; compiler wants this sys-modules only: '(sortbase) *system-modules*) (list *current-module*) (mod-flatten-context (mod-get-context *current-module* ))) :from-end t))) (when verbose-p (mod-print-module-names list-of-module-names :text "Collecting modules for the emulator:" :newline t)) (mapcar #'mod-get-list-of-items list-of-module-names) )) (defun mod-flatten-databases () "Returns a flat list of clauses of the current context." (let ((flat-list-of-clauses (mod-append (mod-collect-databases :reduced-sys-modules-p t :verbose-p t)) )) ;; (rf-format "~%--- Resulting flat list:---~%") ;; (rf-pprint-db flat-list-of-clauses) flat-list-of-clauses )) (defun mod-append (list-of-lists) (if (null list-of-lists) nil (append (car list-of-lists) (mod-append (cdr list-of-lists)) ))) (defun mod-show-tree (context) "Prints the context tree." (let ((*module-level* 0)) (mod-show-tree-aux context) )) (defun mod-show-tree-aux (sym-or-list) (let ((*print-case* :downcase)) (cond ((null sym-or-list)) ((symbolp sym-or-list) (rf-fresh-line) (mod-spaces *module-level*) (rf-princ-like-lisp sym-or-list) (incf *module-level*) (mod-show-tree-aux (mod-get-context sym-or-list)) (decf *module-level*) ) (t (mapc #'mod-show-tree-aux sym-or-list) )))) (defun mod-divide-db (db) "Returns a list ( ) of the db." (mod-divide-db-aux db nil nil) ) (defun mod-divide-db-aux (db list-of-sub-modules list-of-clauses) (cond ((null db) (list (reverse list-of-sub-modules) (reverse list-of-clauses)) ) ((mod-sub-module-t (car db)) (mod-divide-db-aux (cdr db) (cons (car db) list-of-sub-modules) list-of-clauses )) (t (mod-divide-db-aux (cdr db) list-of-sub-modules (cons (car db) list-of-clauses) )))) ;;; --------------------------------------------------------------------------- ;;; ;;; r f i - c o m m a n d s ;;; ;;; --------------------------------------------------------------------------- (defun rfi-cmd-mhelp (userline) "userline = (mhelp)" (when (cdr userline) (rf-princ-like-lisp "Warning: argument ignored.") (rf-terpri) ) (rf-format "~%~A~%~A~%~A~%~A~%~A~%~A~%~A~%~A~%~A~%~A~%~A~%~A~%~A~%~A~%~A~%~A~%~A~%~A~%~A~%~A~%~A~%~A~%~A~%~A~%~%" "Commands of the module system:" " mconsult .. extends the current module" " mreconsult .. extends the current module" " mreplace replaces the contents of the current module" " mtell copies current module to " " mcreate .. creates empty modules" " mdestroy .. removes modules from memory" " mdestroy --all removes all user modules from memory" " mctx= clears the context" " mctx= .. sets the context" " mctx [+|-] .. extends/reduces the context" " mcd makes workspace the current module" " mcd [] sets the current module" " mlisting [] searches along the context for " " ml [] short for mlisting" " minfo shows context and name of current module" " mforest [ ..] shows the module hierarchie" " load .. loads files and creates modules" " reload .. loads files and creates modules" " msave .. saves .. and all of its sub-modules" " map .. executes command on the modules" " map --all executes command on all modules" " mflatten .. creates a flat list of clauses" " mhelp this overview" )) (defun rfi-cmd-mconsult (userline) "userline = (mconsult mod1 mod2 ..)" (if (mod-exists-all-p (cdr userline)) (mapc #'(lambda (module) (mod-set-list-of-items *current-module* ;; next version: save copying by appending from left (append (mod-get-list-of-items *current-module*) (mod-get-list-of-items module)) ) (when (member module (mod-get-context *current-module*)) (let ((*print-case* :downcase)) (rf-format "Warning: ~A is still in the current context.~%" module )) )) (cdr userline) ) (progn (rf-princ-like-lisp "Error: non-existing module.") (rf-terpri) (rf-princ-like-lisp " Nothing is consulted.") ))) (defun rfi-cmd-mreconsult (userline) "userline = (mreconsult mod1 mod2 ..)" (if (mod-exists-all-p (cdr userline)) (mapc #'(lambda (module) (mod-set-list-of-items *current-module* (reconsult (mod-get-list-of-items module) (mod-get-list-of-items *current-module*) ))) (cdr userline) ) (progn (rf-princ-like-lisp "Error: non-existing module.") (rf-terpri) (rf-princ-like-lisp " Nothing is reconsulted.") ))) (defun rfi-cmd-mctx= (userline) "userline = (mctx= mod1 mod2 ..)" (if (mod-exists-all-p (cdr userline)) (progn (mod-modify-descriptor *current-module* :current-context (remove-duplicates (cdr userline) :from-end t) ) (mod-print-context) ) (progn (rf-princ-like-lisp "Error: non-existing module.") (rf-terpri) (rf-princ-like-lisp " Nothing has been changed.") ))) (defun rfi-cmd-mctx (userline) "userline = (mctx [-|+] mod1 ..)" (let (new-context (error-p (not (mod-exists-all-p (remove '- (remove '+ (cdr userline)))))) ) (unless error-p (setq new-context (mctx-aux (cdr userline) nil nil) error-p (null new-context) ) (unless error-p (mod-modify-descriptor *current-module* :current-context (car new-context)) (mod-print-context) )) (when error-p (rf-terpri) (rf-princ-like-lisp " Nothing has been changed.") ))) (defun mctx-aux (userline ctx- ctx+) "Condition on entry: all modules must exist. Value: nil, if error new context as first element of a list, else. " (cond ((and (null userline) (null (intersection ctx- ctx+)) ) (list (remove-duplicates (append (set-difference (mod-get-context *current-module*) ctx-) (reverse ctx+) ) :from-end t))) ((null userline) (let ((*print-case* :downcase)) (rf-princ-like-lisp "Error: +/- mismatch on modules ") (rf-princ-like-lisp (intersection ctx- ctx+)) nil )) ((and (eq '- (first userline)) (mod-exists-p (second userline)) ) (mctx-aux (cddr userline) (cons (second userline) ctx-) ctx+ )) ((and (eq '+ (first userline)) (mod-exists-p (second userline)) ) (mctx-aux (cddr userline) ctx- (cons (second userline) ctx+) )) ((mod-exists-p (first userline)) (mctx-aux (cdr userline) ctx- (cons (first userline) ctx+) )) (t ; error (rf-princ-like-lisp "Error: syntax error.") nil ))) (defun rfi-cmd-mcd (userline &key (verbose-p t)) "userline = (mcd) userline = (mcd mod) " (let ((module (or (second userline) 'workspace ))) (if (mod-exists-p module) (progn (setq*current-module* module) (when verbose-p (rfi-cmd-minfo nil)) ) (progn (rf-princ-like-lisp "Error: module does not exist.") (rf-terpri) )))) (defun rfi-cmd-mreplace (userline) "userline = (mreplace mod)" (let ((module (second userline))) (if (mod-exists-p module) (progn (mod-set-list-of-items *current-module* (copy-list (mod-get-list-of-items module))) (mod-print-context) ) (progn (rf-princ-like-lisp "Error: module does not exist.") (rf-terpri) )))) (defun rfi-cmd-mtell (userline) "userline = (mtell mod) " (let ((module (second userline))) (cond ((and module (mod-exists-p module)) ;; the module exists: (rf-princ-like-lisp "Writing to existing module.") (mod-set-list-of-items module (copy-list (mod-get-list-of-items *current-module*))) (mod-modify-descriptor module :current-context (copy-list (mod-get-context *current-module*)) )) (module ;; the module does not exist: (rf-princ-like-lisp "Creating new module.") (setq*rfi-modules* (append *rfi-modules* (list (mk-module module nil ; annotations (copy-list (mod-get-context *current-module*)) nil ; filename (copy-list (mod-get-list-of-items *current-module*)) ))))) ;; no argument given to mtell: (t (rf-format "~A~%~%" "Error: Use: mtell " ))))) (defun rfi-cmd-mcreate (userline) "userline = (mcreate mod1 ..) " (if (mod-exists-any-p (cdr userline)) (rf-format "Error: Some modules exist~% Nothing has been created.") (progn (rf-princ-like-lisp "Creating new modules.") (mapc #'(lambda (module) (setq*rfi-modules* (append *rfi-modules* (list (mk-module module nil ; annotations nil ; context nil ; filename nil ; items ))))) (cdr userline) )))) (defun rfi-cmd-mdestroy (userline) "userline = (mdestroy mod1 mod2 ..) userline = (mdestroy --all)" (let ((*print-case* :downcase)) (cond ((null (cdr userline)) (rf-format "~A~%~A~%" "Error." "Use: mdestroy .." )) ((and (= 1 (length (cdr userline))) (eq '--all (second userline)) ) (mod-init) (rf-format "All user modules have been destroyed.") ) ((member *current-module* (cdr userline)) (rf-format "~A~%~A~%" "Error: Cannot destroy current module." " Nothing has been destroyed." )) ((member 'workspace (cdr userline)) (rf-format "~A~%~A~%" "Error: Cannot destroy workspace module." " Nothing has been destroyed." )) ((mod-exists-all-p (cdr userline)) (let ((*defer-module-browser-updates* t)) (mapc #'(lambda (module) (rf-format "Removing from memory: ~A~%" module) (setq*rfi-modules* (remove module *rfi-modules* :key #'car)) (mod-modify-descriptor *current-module* :current-context (remove module (mod-get-context *current-module*)))) (cdr userline) ) ;; remove deleted modules from all contexts: (mapc #'(lambda (deleted-module) (mapc #'(lambda (loaded-module) (mod-modify-descriptor loaded-module :current-context (remove deleted-module (mod-get-context loaded-module)))) (mod-get-modules) )) (cdr userline) )) (mod-tcl-mforest) ) (t (rf-format "~A~%~A~%" "Error: Non-existing module." " Nothing has been destroyed." ))))) (defun rfi-cmd-mlisting (userline) "userline = (mlisting pattern)" (let ((pattern (second userline)) (*tcl* nil) (*print-case* :downcase) ) (rf-format "---- ~A:~%" *current-module*) (rfi-cmd-l pattern (mod-get-list-of-items *current-module*)) (mapc #'(lambda (module) (rf-format "---- ~A:~%" module) (rfi-cmd-l pattern (mod-get-list-of-items module)) ) (mod-flatten-context (mod-get-context *current-module*)) ))) (defun rfi-cmd-minfo (userline) (declare (ignore userline)) (let ((*print-case* :downcase)) (rf-princ-like-lisp "Module: ") (rf-princ-like-lisp *current-module*) (rf-terpri) (rf-princ-like-lisp "Context: ") (mapcar #'(lambda (module) (rf-princ-like-lisp module) (rf-princ-like-lisp " ") ) (mod-get-context *current-module*) ))) (defun rfi-cmd-mforest (userline) "userline = (mforest) userline = (mforest mod1 mod2 ..) " (cond ((null (cdr userline)) (mod-show-tree (mod-get-modules)) (update-module-browser 1) ) ((mod-exists-all-p (cdr userline)) (mod-show-tree (cdr userline)) ) (t (rf-princ-like-lisp "Error: Non-existing module.") ))) (defun rfi-cmd-load (userline) "userline = (load module-or-file1 module-or-file2 ..) filenames without extensions " (if (null (cdr userline)) (rf-format "~A~A~A~A~%" "Error." "Use: load .." ) (let ((module-file-list (mapcar #'mod-gen-name-pair (cdr userline))) (*module-level* 0) ) (if (member nil module-file-list) (rf-format "~A~%~A~%" "Error: Non-existing module/file." " Nothing has been loaded." ) (mapc #'(lambda (module-dot-file) (mod-load-module (car module-dot-file) :full-filename (cdr module-dot-file) )) module-file-list ))))) (defun rfi-cmd-reload (userline) "userline = (reload) userline = (reload mod1 mod2 ..) " (let* ((modules (or (cdr userline) (list *current-module*) )) (filenames (mapcar #'mod-get-filename modules)) (*module-level* 0) ) (cond ((not (mod-exists-all-p modules)) (rf-format "~A~%~A~%" "Error: Non-existing module." " Nothing has been reloaded." )) ;; all modules exist: ((mod-filename-all-p modules) ;; every module has a filename: (mapc #'mod-reread-from-file modules filenames) ) (t (rf-format "~A~%~A~%" "Error: No filename." " Nothing has been reloaded." ) nil )))) (defun rfi-cmd-msave (userline) "userline = (msave mod1 mod2 ..)" (let* ((modules (or (cdr userline) (list *current-module*) )) (*module-level* 0) ) (cond ((not (mod-exists-all-p modules)) (rf-format "~A~%~A~%" "Error: Non-existing module." " Nothing has been saved." )) ;; all modules exist: (t (mapc #'(lambda (module) (mod-save-module-and-sub-modules module :ask-if-exists-p t)) modules ))))) (defun rfi-cmd-map (userline) "userline = (map rfi-cmd mod1 mod2 ..) userline = (map rfi-cmd --all) Executes the rfi-cmd on all of its arguments. " (let ((*print-case* :downcase) (the-current-module *current-module*) (rfi-cmd (second userline)) the-modules ) (cond ((< (length (cdr userline)) 2) (rf-format "~A~%~A~%~A~%" "Error." "Use: map .." " map --all" )) ((not (rfi-command-p (list rfi-cmd))) (rf-format "~A~%~A~A~%" "Error." "Not a rfi-command: " rfi-cmd )) ((and (= 2 (length (cdr userline))) (eq '--all (third userline)) ) (setq the-modules (mod-get-modules)) ) ((mod-exists-all-p (cddr userline)) (setq the-modules (cddr userline)) ) (t (rf-format "~A~%~A~%" "Error: Non-existing module." " Nothing has been done." ))) (when the-modules ; no error (mapc #'(lambda (mod) (rf-format "---- Doing ~A on module ~A:~%" rfi-cmd mod ) (rfi-cmd-mcd (list 'mcd mod) :verbose-p nil) (rfi-command (list rfi-cmd)) ) the-modules ) (rfi-cmd-mcd (list 'mcd the-current-module) :verbose-p nil) ))) (defun rfi-cmd-mflatten (userline) "userline = (mflatten mod1 mod2 ..) Output goes into current module. " (let* ((modules (or (cdr userline) (list *current-module*) )) flat-module-names ) (cond ((not (mod-exists-all-p modules)) (rf-format "~A~%~A~%" "Error: Non-existing module." " Nothing has been done." )) ;; all modules exist: (t (setq flat-module-names (mod-flatten-context modules)) (when t;; *mod-verbose-p* (mod-print-module-names flat-module-names :text "Modules: ") ) (mod-set-list-of-items *current-module* (mod-append (cons (mod-get-list-of-items *current-module*) (mapcar #'mod-get-list-of-items flat-module-names) ))))))) ;;; --------------------------------------------------------------------------- ;;; ;;; M i s c ;;; ;;; --------------------------------------------------------------------------- (defun mod-sub-module-t (item) "<==> item = (mod )" (and (consp item) (eq 'md (car item)) )) (defun mod-sub-module (item) (second item) ) (defun mod-mk-sub-module (module) (list 'md module) ) (defun mod-gen-name-pair (sym-or-string) "Returns a pair: (module-as-symbol . full-filename). Errormsg. if file not found. " (cons (read-from-string (pathname-name sym-or-string)) ; name of module (mod-gen-filename sym-or-string)) ) (defun mod-gen-filename (sym-or-string &key (path *module-directories*) (search-path-p (symbolp sym-or-string)) (signal-error-p t)) "Returns a string containing the full filename for module. NIL, if not found. Error message if signal-error-p is t. " (if search-path-p (mod-gen-filename-1 sym-or-string path signal-error-p) (let ((file-rfp (rfi-extension (string sym-or-string) ".rfp")) (file-rf (rfi-extension (string sym-or-string) ".rf")) ) (cond ((probe-file file-rfp) file-rfp ) ((probe-file file-rf) file-rf ) (signal-error-p (rf-format "Cannot find: ~A or ~A~%" file-rfp file-rf) nil ) (t nil ))))) (defun mod-gen-filename-1 (module path signal-error-p) (cond ((mod-get-filename module)) (t (mod-gen-filename-2 module path signal-error-p) ))) (defun mod-gen-filename-2 (module path signal-error-p) "Returns a full path name, describing the position of module (a symbol) in the path of module directories. " (cond ((null path) (if signal-error-p (rf-error "Cannot find " (string module)) nil )) ((probe-file (rfi-extension (stringcat (car path) (string-downcase (string module)) ) ".rfp" ))) ((probe-file (rfi-extension (stringcat (car path) (string-downcase (string module)) ) ".rf" ))) (t (mod-gen-filename-2 module (cdr path) signal-error-p)))) (defun mk-module (module annotations sub-modules filename items) (list module annotations sub-modules filename items nil sub-modules) ) (defun mod-get-sub-modules (module) "Returns the list of sub-modules. NIL if module is not defined. " (let ((module-descriptor (mod-get-descriptor module))) (if module-descriptor (third module-descriptor) nil ))) (defun mod-get-filename (module &key create-name-p) "Returns the filename of module. NIL, if no filename assigned or module unknown. " (let ((module-descriptor (mod-get-descriptor module))) (cond ((not module-descriptor) nil ) ;; module exists: ((fourth module-descriptor)) ; has filename ;; has no filename: (create-name-p (rfi-extension module (rf-or-rfp)) ) (t nil )))) (defun mod-get-items (module) "Returns the items of module." (let ((module-descriptor (mod-get-descriptor module))) (if module-descriptor (fifth module-descriptor) nil ))) (defun mod-get-modified (module) "Returns the modified predicate of module." (let ((module-descriptor (mod-get-descriptor module))) (if module-descriptor (sixth module-descriptor) nil ))) (defun mod-get-context (module) "Returns the current context of module." (let ((module-descriptor (mod-get-descriptor module))) (if module-descriptor (seventh module-descriptor) nil ))) (defun mod-get-descriptor (module &key (module-list *rfi-modules*)) (assoc module module-list) ) (defun mod-modify-descriptor (module &key (annotations nil annotations-p) (sub-modules nil sub-modules-p) (filename nil filename-p) (items nil items-p) (modified nil modified-p) (current-context nil current-context-p) ) (let ((module-descriptor (mod-get-descriptor module))) (when (null module-descriptor) (rf-error "Internal error in ." "Unknown module." "Please contact a guru." )) (setf (sixth module-descriptor) t) ; modified-p (when annotations-p (setf (second module-descriptor) annotations)) (when sub-modules-p (setf (third module-descriptor) sub-modules)) (when filename-p (setf (fourth module-descriptor) filename)) (when items-p (setf (fifth module-descriptor) items)) (when modified-p (setf (sixth module-descriptor) modified)) (when current-context-p (setf (seventh module-descriptor) current-context) (mod-tcl-mforest)) )) (defun mod-get-list-of-items (module) "See also mod-get-items." (let ((items-or-variable (mod-get-items module))) (if (or (consp items-or-variable) (null items-or-variable) ) items-or-variable (symbol-value items-or-variable) ))) (defun mod-set-list-of-items (module list-of-items) (let ((items-or-variable (mod-get-items module))) (if (or (consp items-or-variable) (null items-or-variable) ) (mod-modify-descriptor module :items list-of-items) (set items-or-variable list-of-items) ))) (defun mod-get-modules () "Returns a list of all loaded module-names." (mapcar #'car *rfi-modules*) ) (defun mod-exists-all-p (list-of-modules &key (signal-error-p t)) "<==> all modules exist" (let ((*print-case* :downcase)) (cond ((every #'mod-exists-p list-of-modules)) (signal-error-p (mapc #'(lambda (module) (unless (mod-exists-p module) (rf-format "There is no module ~A~%" module) )) list-of-modules ) nil) (t nil )))) (defun mod-exists-any-p (list-of-modules &key (signal-error-p t)) "<==> at least one module exists" (let ((*print-case* :downcase)) (cond ((notany #'mod-exists-p list-of-modules) nil ) (signal-error-p (mapc #'(lambda (module) (when (mod-exists-p module) (rf-format "Module ~A exists.~%" module) )) list-of-modules ) t) (t t )))) (defun mod-exists-p (module) "<==> module exists in memory." (member module *rfi-modules* :key #'car) ) (defun mod-filename-all-p (list-of-modules &key (signal-error-p t)) "<==> every module has a filename" (cond ((every #'mod-get-filename list-of-modules)) (signal-error-p (mapc #'(lambda (module) (unless (mod-get-filename module) (rf-format "Module ~A has no filename.~%" module) )) list-of-modules ) nil) (t nil ))) (defun mod-print-context (&optional (context (mod-get-context *current-module*))) (mod-print-module-names context :text "Context: ") ) (defun mod-print-module-names (list-of-module-names &key text newline) (let ((*print-case* :downcase)) (when text (rf-princ-like-lisp text)) (when newline (rf-terpri)) (mapc #'(lambda (module) (rf-princ-like-lisp module) (rf-princ-like-lisp " ") ) list-of-module-names ))) (defun mod-spaces (n) (spaces (* 2 n)) ) ;;; --------------------------------------------------------------------------- ;;; ;;; Interface to rfi.lisp ;;; ;;; --------------------------------------------------------------------------- (defun get-sysbase (module) (if (member module *system-modules*) (mod-get-list-of-items module) (rf-error "Internal error in ." "Unknown system module."))) (defun set-sysbase (module items) (if (member module *system-modules*) (mod-set-list-of-items module items) (rf-error "Internal error in ." "Unknown system module."))) ;;; --------------------------------------------------------------------------- ;;; ;;; TCL extensions for visual interaction with module forest (MS 9/95) ;;; ;;; --------------------------------------------------------------------------- (defun setq*rfi-modules* (modules) (setq *rfi-modules* modules) (mod-tcl-mforest)) (defun setq*current-module* (module) (setq *current-module* module) (mod-tcl-mforest)) (defun mod-tcl-mforest () (when (and *tcl* (not *defer-module-browser-updates*)) (let* ((modules (mod-get-modules)) (modules-in-context (mapcan #'(lambda (mod) (copy-list (mod-get-context mod))) modules))) (mod-tcl-show-tree modules modules-in-context) (update-module-browser)))) (defun mod-tcl-show-tree (modules modules-in-context) (format t "~a{Eval:.status.modulebrowser.list delete 0 end~a}" *esc* *esc*) (format t "~a{Eval:.status.modulebrowser.list insert 0" *esc*) (let ((*module-level* 0)) (mod-tcl-show-tree-aux modules modules-in-context)) (format t "~a}" *esc*)) (defun mod-tcl-show-tree-aux (sym-or-list modules-in-context) (let ((*print-case* :downcase)) (cond ((null sym-or-list)) ((symbolp sym-or-list) (unless (and (zerop *module-level*) (member sym-or-list modules-in-context)) (princ " \"") (mod-tcl-spaces *module-level*) (if (eq *current-module* sym-or-list) (let ((*print-case* :upcase)) (princ sym-or-list)) (princ sym-or-list)) (princ "\"") (incf *module-level*) (mod-tcl-show-tree-aux (mod-get-context sym-or-list) modules-in-context) (decf *module-level*))) (t (mapc #'(lambda (m) (mod-tcl-show-tree-aux m modules-in-context)) sym-or-list))))) (defun mod-tcl-spaces (n) (dotimes (i n) (princ " "))) (defun update-module-browser (&optional (force 0)) (when *tcl* (format t "~a{Eval:initModules ~a~a}" *esc* force *esc*) (mapc #'(lambda (mod) (if (eq mod *current-module*) (let ((*print-case* :upcase)) (format t "~a{Eval:placeNode {~a} current~a}" *esc* mod *esc*)) (let ((*print-case* :downcase)) (format t "~a{Eval:placeNode {~a} ~a~a}" *esc* mod (if (mod-get-list-of-items mod) 'normal 'empty) *esc*)))) (mod-get-modules)) (mapc #'(lambda (mod) (mapc #'(lambda (mod2) (let ((*print-case* :downcase)) (format t "~a{Eval:connectNodes {~a} {~a}~a}" *esc* mod mod2 *esc*))) (mod-get-context mod))) (mod-get-modules)) (format t "~a{Eval:updateLayout~a}" *esc* *esc*))) ;;; --------------------------------------------------------------------------- (mod-init) ; init the module package (pushnew :rf-modules *features*) ;;;### eof ;;;### File "utility.lisp" ; ----------------------------------------------------------------------------- ; ; COMMON LISP extending utilities ; ; ----------------------------------------------------------------------------- ;(defun ncons (x) (cons x nil)) ;************************************************************************ ; Sort a DAG, given as described below (c) M. Sintek ;************************************************************************ (defun sort-depexpr (exprs) ; exprs = ((expr1 . dep-expr1) ...) ; returns sorted "items" (or :cyclic if exprs are cyclic) (let ((base* (mapcan #'(lambda (expr) (unless (cdr expr) (list (car expr)))) exprs)) (exprs* (mapcan #'(lambda (expr) (when (cdr expr) (list expr))) exprs))) (if exprs* (let ((base (union base* (set-difference (remove-duplicates (apply #'append (mapcar #'cdr exprs*)) :test #'equal) (mapcar #'car exprs*) :test #'equal) :test #'equal))) (if base (let ((rest-bases (sort-depexpr (mapcar #'(lambda (expr) (cons (car expr) (set-difference (cdr expr) base :test #'equal))) exprs*)))) (if (eq rest-bases :cyclic) :cyclic (append base rest-bases))) :cyclic)) base*))) ;;;### eof ;;;### File "initial.lisp" (defun rfi-set-interactive-mode () (setq *rfi-input-mode* 'interactive)) (defun rfi-interactive-mode-p () (eq *rfi-input-mode* 'interactive)) (defun rfi-set-batch-mode () (setq *rfi-input-mode* 'batch)) (defun rfi-batch-mode-p () (eq *rfi-input-mode* 'batch)) (defun setq*rfi-machine* (machine) (setq *rfi-machine* machine) (when *tcl* (format t "~a{Eval:set machinemsg ~a ~a}" *esc* machine *esc*))) (defun rfi-set-emulator-mode () (setq gasm.*default-unknown-label* gwam.*unknown-label*) (setq gasm.*default-module* 'user) (setq*rfi-machine* 'emulator) (rfi-cmd-style (list 'style *style*))) (defun rfi-set-interpreter-mode () (setq*rfi-machine* 'interpreter) (rfi-cmd-style (list 'style *style*))) (defun rfi-set-emuc-mode () (setq*rfi-machine* 'emuc) (rfi-cmd-style (list 'style *style*))) (defun rfi-interpreter-mode-p () (eq 'interpreter *rfi-machine*)) (defun rfi-emulator-mode-p () (eq 'emulator *rfi-machine*)) (defun rfi-emuc-mode-p () (eq 'emuc *rfi-machine*)) (defun ll-mode-p () (eq *rfi-machine* 'll)) (defun rfi-script-mode-p () (not (null *rfi-script-output*))) ; ----------------------------------------------------------------------------- ; ; layout initializations ; ; ----------------------------------------------------------------------------- (setq *print-length* 100) (setq *print-level* 100) ; ; reset relfun = destroy command ; (defun rfi-cmd-destroy () (setq *rfi-database* nil) (setq *ll-db* nil) (reset-rf-class-definitions) (setq *tupstructs* '(tupstruct)) (reset-horizon-macros) (setq *mode-declarations* nil) (setq *complete-definitions* nil) (mod-modify-descriptor *current-module* :current-context nil :items nil )) ; these functions are defined in the emulator: (defun reset-rf-class-definitions () nil) (defun reset-horizon-macros () nil) (defun instance-classes (&rest args) (error "instance-classes called with ~s" args)) ; ; set defaults ; (defun rfi-init () (if (streamp *rfi-script-input*) (close *rfi-script-input*)) (if (streamp *rfi-script-output*) (close *rfi-script-output*)) (setq *rfi-commands* '(a0 a0ft a0hn az azft azhn timermode builtins classify codegen ; M.P. 7/96 compile consult destroy dynamic emuc emul endscript exec extrarg deanon flatten flatter footen footer help horizon inter l lconsult bye listing listclass listcode load-database query ; only used in RuleGen lreplace ltell m modes more nospy normalize ori passtup pausebye nopausebye prelude relationalize rf2pl rfp2pl rx rxft rxhn replace size script showdepth singlify spy static style tell untup version verti fc-init break ;(Klaus 30.09.1990) indexing ; INDEXING -- real-fun asm assem uncertain uncomma untype hitrans ; Sintek/Hall 92/94 unor ; M.S. 28.02.92 unlambda ; M.S. 30.04.92 unmacro ; M.S. 18.05.92 undeclare orf unorf ; M.S. 12/94 deta fd2ll llc ; M.S. 12/94 cd pwd ls !! ll edit ; M.S. 8.11.94 rf2rf rf2rfp rfp2rf rfp2rfp bal2bap bap2bal sl sp sx trace untrace notrace miser-level print-width ; untrace old sortstyle resubsumes sortbase ; Hall 94 consult-sortbase compile-sortbase destroy-sortbase browse-sortbase complete-taxonomy unique-glb unsubsumes mconsult mreconsult mreplace ; Herfert 95 mctx mctx= mcd mtell mcreate mdestroy mlisting ml minfo mforest msave load quitwam ; M.P. 7/96 reload map mflatten mhelp hash reconsult )) (setq *rf-print-width* 80) (setq *rfi-standard-output* *standard-output*) (setq *rfi-standard-input* *standard-input*) (setq *rfi-script-output* nil) (setq *rfi-script-input* nil) (rfi-set-interactive-mode) (if (not *rfi-readtable*) (progn (setq *rfi-readtable* (copy-readtable)) (rfi-set-syntax))) (if (not *rfi-ori*) (setq *rfi-ori* '((is t nil)))) (if (not *rfi-showdepth*) (setq *rfi-showdepth* 0)) (if (not *rfi-machine*) (rfi-set-interpreter-mode)) (if (not (get-sysbase 'prelude)) (rfi-load-prelude)) (if (not (get-sysbase 'tracebase)) (rfi-load-tracer) ) ) (rfi-init) ; initialization of LISP functions, predicates etc. (defmacro declare-rf-builtins (var &rest symbols) `(progn (setq ,var ',symbols) #+CLiCC (declare-funcallable ,@symbols))) (declare-rf-builtins *lisp-static-functions* + - * / 1+ 1- abs rem floor ceiling truncate round sqrt expt log sin cos tan asin acos atan max min mod 1th 2th th1 1rest 2rest rest1 1start 2start start1 len app ; intersection union set-difference remove-duplicates ; -> prelude princ-to-string setvar format-to-string format-to-string* code-char instance-classes) (declare-rf-builtins *lisp-dynamic-functions* gentemp random date operators getvar) (setq *lisp-functions* (append *lisp-static-functions* *lisp-dynamic-functions*)) (declare-rf-builtins *lisp-predicates* < <= = /= > >= string< string<= string= string/= string> string>= ; null ; -> prelude atom symbolp numberp integerp plusp minusp) (declare-rf-builtins *relfun-extras* ; (Klaus 30.09.1990) trueatom nontrueatom var nonvar) (declare-rf-builtins *lisp-extras* break readl relfun rf-print rf-princ rf-terpri rf-fresh-line rf-pprint rf-format pretty-print wait err tracer-increment-level tracer-decrement-level tracer-check-max tracer-print-heading tracer-print-head tracer-print-foot tracer-print-hn-or-ft tracer-cps) ; ----------------------------------------------------------------------------- ; ; print start message... ; ; ----------------------------------------------------------------------------- (terpri) (princ "RFI - Version : ") (princ *rfi-version*) (terpri) (princ " - functions improved:") (terpri) (princ " - readl") (terpri) (princ " - consult/replace") (terpri) (princ " - lconsult/lreplace") (terpri) (princ " - batch-command") (terpri) (princ " - script-command") (terpri) (princ " - listclass") (terpri) (princ " - transform-query-for-emulator") (terpri) (princ " - footen-command") (terpri) (princ " - new functions:") (terpri) (princ " - footer") (terpri) (princ " - showdepth-command") (terpri) (princ " - pretty-print-functions moved to *lisp-extras*") (terpri) (princ " - *rfi-readtable* is modified instead of lisp *readtable*") (terpri) (princ " - spy/nospy also affects compiler/emulator") (terpri) (princ " - consult/replace works for files with multiple setq or with untagged clauses") (terpri) (princ " - lconsult/lreplace works also with untagged clauses or expanded macros") (terpri) (princ " - bar is legalized") (terpri) (princ " - query for emulator is transformed to special footed-procedure 'main'") (terpri) (princ " - footer: change radically hn- to ft-clauses") (terpri) (princ " - showdepth: length spy-trace is displayed with stars") (terpri) (princ " - PLEASE NOTE: It's enough to say compile (does horizon & verti)") (terpri) (princ " - call for meta-calls is generalized and renamed to ecal (eval+call)") (terpri) (princ " - spy shows backquotes of structures bound to variables etc.") (terpri) (princ " - horizon/compile: flatter, normalize, footen; mode-interpreter interface") (terpri) (princ " - once, naf, toplevel renamed to relfun, interface function rf") (terpri) (princ " - initial cut generalized to single cut: (hn (foo _x) ... ! ...)") (terpri) (princ " - bagof-like tupof: (tupof (likes john _x) `(ok _x)) RETURNS tup of (ok _x)") (terpri) (princ " - access function rf complies to COLAB specification") (terpri) (princ " - command deanon for databases and automatic deanonymization of requests") (terpri) (princ " - COLAB partners fw, cn, tx are NOW ACCESSIBLE AS LISP ***FUNCTIONS***") (terpri) (princ " - error handling improved and rf-pprint also returns its arg") (terpri) (princ " - command relationalize (flatten + extrarg) puts return into FIRST arg") (terpri) (princ " - command singlify transforms multi-footed clauses to single-footed ones") (terpri) (princ " - commands builtins changed, version introduced") (terpri) (princ " - flatter now treats complex is lhs") (terpri) (princ " - database is LIST of lists, or-process has db-left/db-right args, prelude") (terpri) (princ " - cns is interpreted as LISP cons, normalize command, rf-terpri returns t") (terpri) (princ " - (foot-)sole cut returns proper value: (ft (foo _x) ... v !) => v'") (terpri) (princ " - PROLOG-style syntax can be loaded; static-flattener uses mk-inst") (terpri) (princ " - relfun made recursive for interaction breaks in batch; lisp renamed bye") (terpri) (princ " - exec made recursive for recursive batch files (cf. recursive includes)") (terpri) (princ " - value-returning clause primitive (clause `(tag head | body))") (terpri) (princ " - integrated: PROLOG-style syntax and new horizontals (uncomma ...)") (terpri) (princ " - date/time-returning date builtin (date); rfi-predicates -> operators") (terpri) (princ " - large file rfi.lsp 'perforated' into smaller ones, hence 'unpackable'") (terpri) (princ " - tupof, once, naf flattened only internally") (terpri) (princ " - finite domains (dom) and in-place bindings (bnd), without instantiation") (terpri) (princ " - renaming of extralogicals to var/nonvar trueatom/nontrueatom") (terpri) (princ " - integrated: (un)trace, miser-level, print-width, rf(p)2rf(p) translations") (terpri) (princ " - dom and bnd modified, with bnd-bnd-less, result-only instantiation") (terpri) (princ " - emulator more; pass(ivate)tup command, relationalize and horizon adapted") (terpri) (princ " - finite exclusions (exc) introduced and integrated with dom/bnd; size cmd") (terpri) (princ " - footen and footer commands need foot as extra argument (horizon: true)") (terpri) (princ " - speedup by entry-exit indexing of ('distributed') procedures; timermode cmd") (terpri) (princ " - uncertainty clauses with uc tag or ':-#' neck; horizontal uncertain cmd") (terpri) (princ " - Unix shell escapes for cd, pwd, ls, !!, edit") (terpri) (princ " - 'sort = $predicate/1'; *sortbase*-defined; dynamic/static glb-unification") (terpri) (princ " - Object-centered RF (ORF) and LISP light (ll) interfaces; TCL/TK graphics") (terpri) (princ " - dot unification abolished; absynt cleaned up/documented paradigmatically") (terpri) (princ " - reconsult and module system introduced") (terpri) (princ " - TCL module browser, LISP error ignorer introduced; LISP evals eliminated") (terpri) (princ " - rfi.lisp and syntra.lisp made CLiCCable; load order via relfun.lisp") (terpri) (princ " - bnd generalized for multiple-occurrence variables, patterns, etc.") (terpri) (princ " - static deanonymization extended, dynamic deanonymization introduced: bnd") (terpri) (princ " - ultimate-instant purified via independent globalize: values and builtins") (terpri) (princ " - dynamic assertz with early update visibility: and-process changed") (terpri) (princ " - dynamic retractx with early update visibility: and-process changed") (terpri) (princ " - dynamic, multiple, environment-specializing signatures as sg clauses") (terpri) (princ " - 'builtin-sort = $atom-subpredicate/1'; (user-)sort case: typ-exc. mod -> md") (terpri) (princ " - passtup generalized to active cns's (not in prelude) to simplify horizon") (terpri) (princ " - RAWAM access (emuc,quitwam); verti parts (classify,codegen); dyn. lisp-fcts") (terpri) (princ " - builtins generalized: inner vars and structs, preds with outer structs") (terpri) (princ " - intersection, union, set-difference, remove-duplicates, null: prelude; err!") (terpri) (princ " - *gensym-counter* (re-)initialized to 1 for easier script diffs") (terpri) (princ " - final values and bindings de-bnd'ed immediately before printing") (terpri) (princ " - pausebye/nopausebye to exchange active/passive pause clauses; un->notrace") (terpri) (princ " - rfml.lisp: RF Markup Language output style, try sx, XML DTD: www.relfun.org") (terpri) (princ " - report errors to boley@informatik.uni-kl.de") (terpri) (princ " - start by typing (relfun)") (terpri) (terpri) ; Indicate that the RELFUN interpreter was loaded successfully to others ; in the same LISP image: (pushnew :relfun *features*) ; this should stay the last expression in the file #+CLiCC (relfun) ;;;### eof