;;;### File "ezlist.lisp" ;;; Copyright Notice ;;; ;;; This software is distributed for non-profit and research purposes only. ;;; Non-profit redistribution of the current version or parts of the current ;;; version is permitted if this copyright notice is included unchanged. ;;; We give no warranty of any kind for this prototype. It will be further ;;; improved as time permits. ;;; ;;; Michael Herfert, Harold Boley (boley@informatik.uni-kl.de) ;;; History (see individual modules for details): ;;; Feb. 93: First version [MH] ;;; Feb. 96: CLiCCable version [WG,UH,MP,MS] ;;; June 96: mod -> md [HB,MS] ;;; Aug. 96: ":-&" -> ":- &" [HB] ;;; Feb. 97: New PROLOG-like clause syntax (newsyn, part 1) implemented [HB] ;;; Mar. 97: New PROLOG-like is syntax (newsyn, part 2) implemented [HB] ;;; Mar. 97: ":&-3" scanned as ":& -3"; ":-&" scanned as ":- &" [HB] ;;; Sep. 97: New valued-conjunction top-level [MP] ;;; Nov. 97: Corrected newsyn for printing iso-prolog is in rfp2pl/rf2pl [MP] ;;; Apr. 98: gensyms to be seen by the user replaced by gentemps [HB] ;; ---------------- global variables and constants --------------------------- (defconstant the-non-printing-char (code-char 0)) ;; Easy life for the editor: (defconstant sqr-left #\[) (defconstant sqr-right #\]) (defconstant round-left #$) (defconstant round-right #$) (defconstant comma #\,) (defconstant bar #\|) (defconstant eof-char (code-char 4)) (defvar *style* 'prolog) ; pre-defvarred (defvar *rfi-standard-output* nil) ; only for CLiCC (defvar *print-like-prolog* nil "<==> the pretty-printer uses the syntax of Prolog, not the prologish syntax of Relfun ") ;; -------------------------- M a c r o s ----------------------------------- (defmacro accept-token-type (tok-type) ;; Signals an error, if the wrong token is found, ;; otherwise it reads in the next token. `(if (eq (funcall scanner 'last-token-type) ,tok-type) (funcall scanner) (signal-error scanner (format nil "Expected: ~A~%Found: " (tok-type->string ,tok-type) ) (funcall scanner 'last-token) ))) (defmacro stringcat (&rest strings) `(concatenate 'string ,@strings )) (defmacro append* (var-sym a-list) ;; easy to type `(setq ,var-sym (append ,var-sym ,a-list)) ) (defmacro let-assoc ((fct-id item assoc-list) then-form else-form) ;; assoc-list = ( (key-1 . fct-1) (key-2 . fct-2) .. ) ;; If item is in assoc-list then the corresponding function is called ;; with then-args as arguments. ;; Else then-args are not evaluated and else-form is executed. ;; Example: ;; (let-assoc (g symbol *extra-parsing-fcts*) ;; (g scanner nil) ;; (parse-round-list scanner nil) ) `(let ((pair (assoc ,item ,assoc-list))) (if (null pair) ,else-form (flet ((,fct-id (&rest args) (apply (symbol-function (cdr pair)) args))) ,then-form )))) #| ----------------------------- e z l i s t ----------------------------------- This section defines four macros to access parts of a list by providing a simple kind of pattern matching. let+ is an extension of let. Syntax: LET+ ({var | (var value) | (pattern value)}*) {form}* let*+ is an extension of let*. Syntax: LET*+ ({var | (var value) | (pattern value)}*) {form}* get-el replacement for car, cdr, c..r Syntax: GET-EL pattern form set-el replacement for rplacar, rplacdr, setf (set-el replaces only the list-acces facilities of setf). Syntax: SET-EL {pattern form value}* Pattern is a s-expr made of strings, symbols and patterns: string | symbol | (pattern [. pattern]) Example 1: ========== (let*+ ((a 1) ((el1 el2) (g a)) (b 2) ) ) expands to to: (let* ((a 1) (#:|let-161| (g a)) (el1 (nth 0 #:|let-161|)) (el2 (nth 1 #:|let-161|)) (b 2)) ) Example 2: ========== (let*+ (((hn-or-ft (functor . arguments) . factors) clause )) ) expands to to: (let* ((#:|let-162| clause) (hn-or-ft (nth 0 #:|let-162|)) (functor (nth 0 (nth 1 #:|let-162|))) (arguments (nthcdr 1 (nth 1 #:|let-162|))) (factors (nthcdr 2 #:|let-162|))) ) Example 3: ========== A string can be used to disable the generation of an access function: (let*+ ((a 1) (("el1" el2) (g a)) (b 2) ) ) expands to to: (let* ((a 1) (#:|let-161| (g a)) (el2 (nth 1 #:|let-161|)) ; compare with first example (b 2)) ) Example 4: ========== (get-el ("tag" (head-functor . "head-args") . "body") clause) expands to to: (nth 0 (nth 1 clause)) The pattern must contain exact one symbol. Example 5: ========== (set-el ("tag" (head-functor . "head-args") . "body") clause new-head-functor ) expands to to: (setf (nth 0 (nth 1 clause)) new-head-functor) The pattern must contain exact one symbol. Emacs users loading cl-indent.el may place the following s-expr in .emacs to format the new macros correctly (tested with Emacs 18.59): (let ((l '((let+ ((&whole 4 &rest (&whole 1 1 2)) &body)) (let*+ . let+) ))) (while l (put (car (car l)) 'common-lisp-indent-hook (if (symbolp (cdr (car l))) (get (cdr (car l)) 'common-lisp-indent-hook) (car (cdr (car l))))) (setq l (cdr l)) )) |# (defmacro let*+ (variables &rest body-exprs) (list* 'let* (let*0 variables) body-exprs) ) (defmacro let+ (variables &rest body-exprs) (let0 variables body-exprs) ) (defun let*0 (variables) (if (null variables) nil (let ((item (car variables))) (append (cond ((atom item) (list item)) ((atom (car item)) (list item)) (t (let*1 (first item) (second item))) ) (let*0 (rest variables)) )))) (defun let*1 (symbols value) (if (null value) (error (concatenate 'string "While expanding let*+:~%" " Value form is NIL (resp. not supplied) !~%" " Pattern: ~S~%" ) symbols ) (let ((temp-var (gensym "let-"))) (cons (list temp-var value) (gen-list-access-functions symbols temp-var) )))) (defun let0 (list-of-tuples body-exprs) (let (body-prefix new-lot) (do* ((lot list-of-tuples (rest lot)) (sym-value (first lot) (first lot)) new-sym-value temp-sym ) ((null lot) (setq new-lot (reverse new-lot)) ) (cond ((or (atom sym-value) (atom (first sym-value)) ) ;; it's a normal clause of let: (setq new-lot (cons sym-value new-lot)) ) ;; it's a pattern: ((null (second sym-value)) ;; no value form provided: (error (concatenate 'string "While expanding let+:~%" " Value form is NIL (resp. not supplied) !~%" " Pattern: ~S~%" ) (first sym-value) )) (t ;; process pattern: (setq temp-sym (gensym "let-") new-sym-value (list temp-sym (second sym-value)) body-prefix (cons (list (first sym-value) temp-sym) body-prefix ) new-lot (append (tree2symbol-list (first sym-value)) (list new-sym-value) new-lot) )))) (list* 'let new-lot (gen-setq body-prefix) body-exprs) )) (defun gen-setq (body-prefix) ;; body-prefix = ((

) ..) ;; Value: (setq

..) (let (l) (mapc #'(lambda (pattern-and-temp-sym) (setq l (append l (gen-list-access-functions (first pattern-and-temp-sym) (second pattern-and-temp-sym) )))) body-prefix ) (unless (null l) ; return nil if l = nil (cons 'setq (reduce #'append l)) ))) (defun tree2symbol-list (tree) "Returns list of symbols used in tree" (cond ((null tree) nil ) ((stringp tree) nil ) ((atom tree) (list tree) ) (t (append (tree2symbol-list (car tree)) (tree2symbol-list (cdr tree)) )))) (defun gen-list-access-functions (pattern value-form) (gen-list-access-functions-aux pattern value-form 0) ) (defun gen-list-access-functions-aux (symbols value-form n) ;; Example: (gen-list-access-functions-aux '(a b) 'v 0) ;; ==> ;; ((a (nth 0 v)) ;; (b (nth 1 v)) ) (cond ((null symbols) nil ) ((stringp symbols) nil ) ((symbolp symbols) (list (list symbols (list 'nthcdr n value-form))) ) ((stringp (first symbols)) (gen-list-access-functions-aux (rest symbols) value-form (1+ n)) ) ((atom (first symbols)) (cons (list (first symbols) (list 'nth n value-form) ) (gen-list-access-functions-aux (rest symbols) value-form (1+ n)) )) (t (append (gen-list-access-functions-aux (first symbols) (list 'nth n value-form) 0 ) (gen-list-access-functions-aux (rest symbols) value-form (1+ n)) )))) (defmacro get-el (pattern a-list) (let ((acc-functions (gen-list-access-functions pattern a-list))) (if (/= 1 (length acc-functions)) (error "~A~A :~%~A~%" "While expanding " (list 'get-el pattern a-list) "There must be exact one symbol in pattern." ) (cadar acc-functions) ))) (defmacro set-el (&rest tripels) (if (= 0 (mod (length tripels) 3)) (set-el1 tripels nil) ; nil: result of expansion (error "~A~A :~%~A~%" "While expanding " (cons 'set-el tripels) "Number of arguments is not a multiple of 3." ))) (defun set-el1 (tripels result) (if (null tripels) `(setf ,@result) (let* ((pattern (first tripels)) (form (second tripels)) (new-value (third tripels)) (acc-functions (gen-list-access-functions pattern form)) (acc-function (cadar acc-functions)) ) (if (/= 1 (length acc-functions)) (error "~A~A :~%~A~%" "While expanding " (list 'set-el pattern form new-value) "There must be exact one symbol in pattern." ) (set-el1 (cdddr tripels) (append result (list acc-function new-value)) ))))) (pushnew :rf-ez-list *features*) #| --------------------------- T e s t s ------------------------------------ (load "xpp.lsp") ; xlisp pretty printer (progn (xpp (macroexpand '(let*+ (x (n 10) ((a b c) (f n)) (m 20) ) (setq xx 10) (fac 10) ))) (let*+ (((hn-or-ft (functor . arguments) . body) '(ft (facrel n r) (* 10 n)) ) ((a b c . d) '(1 2 3 4 5 6 7)) ) (format t "hn-or-ft: ~A~%functor: ~A~%arguments: ~A~%body: ~A~%a: ~A~%b: ~A~%c: ~A~%d: ~A~%" hn-or-ft functor arguments body a b c d)) ) (progn (xpp (macroexpand '(let*+ ((a 1) ((el1 el2) (g a)) (b 2) )))) (xpp (macroexpand '(let+ (x (n 10) ((a (b . c)) (f 4)) (m 20) ((x "y" z) (g 8)) ) (setq xx 10) (fac 10) ))) (xpp (macroexpand '(let+ ((x 20) ((a b) (f 20)) y ) (g 30) ))) (let+ ((x "This is x") ((a1 (a2 a3 . a4) (a5)) '(1 (2 3 . 4) (5))) (y "This is y") ) (format t "x: ~A~%a1: ~A~%a2: ~A~%a3: ~A~%a4: ~A~%a5: ~A~%y: ~A~%" x a1 a2 a3 a4 a5 y) ) ) ;; An error: (xpp (macroexpand (quote (let*+ ((x "This is x") ((a1 (a2 a3 . a4) (a5))) ; <== error (y "This is y") ) (format t "x: ~A~%a1: ~A~%a2: ~A~%a3: ~A~%a4: ~A~%a5: ~A~%y: ~A~%" x a1 a2 a3 a4 a5 y) )))) (progn (gen-list-access-functions '(a b c) 'v) (gen-list-access-functions '(a (x y) c) 'v) (gen-list-access-functions '(a . b) 'v) (gen-list-access-functions '(a (x y . z) c) 'v) ) (macroexpand '(get-el ("tag" (head-functor . "head-args") . "body") clause)) (macroexpand '(set-el ("tag" (head-functor . "head-args") . "body") clause new-head-functor )) (get-el ("a" ("b" el) "c") '(1 (2 444) 5)) (get-el ("a" ("b" el) "c") nil) ; an error (get-el ("a" ("b" el) "c")) ; an error (progn ; an error (setq l '(1 (2 555) 4)) (set-el ("a" ("b" el) "c") l) l ) (progn (setq l '(1 (2 555) 4)) (set-el ("a" ("b" el) "c") l 3) l ) (progn (setq l '(1 (2 888) (4 999 6) 7)) (set-el ("a" ("b" v) . "dont-care") l 3 ("a" "b" ("c" v "d") . "dont-care") l 5) l ) |# ;; ----------------------- e z l i s t E n d ------------------------------- ;;;### eof ;;;### File "tracer.lisp" ;;; Copyright Notice ;;; ;;; This software is distributed for non-profit and research purposes only. ;;; 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. ;;; ;;; Michael Herfert, 1993 (herfert@dfki.uni-kl.de) ;;; History: ;;; Feb. 93: First version [mh] ;;; Nov. 94: *tracebase* (defined in rfi.lisp) ;;; as name for the database used by the tracer ;;; Aug. 95: (get-sysbase 'tracebase) to get the database used by the tracer ;;; because introduction of modules ;;; Oct. 95: trace -all, trace -rest [SA] ;;; Nov. 95: keyword-prefix - [SA] ;; ------------------------- T r a c e r ------------------------------------ ;; ;; Tracer based on the box model of PROLOG. ;; Implemented by horizontal compilation. (defstruct tracing ;; level-now is incremented when entering a traced clause, ;; decremented when exiting. (level-now 0) ;; level-max is used for correct indentation after a more-request. ;; It is compared against level-now everytime a traced clause has succeeded: (level-max 0) ;; first factor in a traced body: (id '+tracer+) ;; id for the print-fail clause added by the tracer: (fail-id '+tracer-fail+) ;; heads = ;; ((head-functor-1 redo-functor-1 org-clauses-1) ... ) (heads nil) ) (defun rf-keywordp (symbol) ;; if prefix is `-' then true (prefix `:' unsuitable because of sort meaning) (if (symbolp symbol) (char= #\- (char (string symbol) 0)))) (defvar tracer (make-tracing) "The state of the tracer.") (defun tracer-reset-to-zero () ;; (princ "tracer-reset-to-zero") (setf (tracing-level-now tracer) 0 (tracing-level-max tracer) 0 )) (defun tracer-reset-to-max () ;; (princ "tracer-reset-to-max") (setf (tracing-level-now tracer) (tracing-level-max tracer) (tracing-level-max tracer) 0 )) (defun tracer-increment-level () (incf (tracing-level-now tracer)) ) (defun tracer-decrement-level () (decf (tracing-level-now tracer)) ) (defun tracer-check-max () (when (> (tracing-level-now tracer) (tracing-level-max tracer)) (setf (tracing-level-max tracer) (tracing-level-now tracer)) ) t ) (defun tracer-print-status () (let ((headlist (tracing-heads tracer))) (if (null headlist) ;; no procedures are traced, SA (rf-princ-like-lisp "No procedures traced") (dolist (triple headlist t) (let+ (((functor "redo-functor" "org-clauses") triple)) (when (traced-p functor) ;; the procedure still exists and is traced: (pp functor) )))))) (defun traced-p (head-functor) ;; Value: nil, if head-functor is not traced. ;; redo-functor, if head-functor is traced and redo-functor ;; is used for redo-detection. ;; (let*+ ((("head-func" redo-functor "org-clauses") (car (member head-functor (tracing-heads tracer) :key #'car :test #'equal ))) (clause (car (member head-functor (get-database) :key #'caadr :test #'equal ))) (("tag" "head" body-1 . "body-rest") clause)) ;; check a clause for tracing (maybe database was destroyed): (and (eq (tracing-id tracer) body-1) redo-functor ))) (defun tracer-book-keeping (head-functor redo-functor org-clauses) ;; store head-functor, .. (let ((l (car (member head-functor (tracing-heads tracer) :key #'car :test #'equal)))) (if l ;; was traced, replace old values destr.: (set-el ("head-functor" redo-functor "org-clauses") l redo-functor ("head-functor" "redo-functor" org-clauses) l org-clauses ) ;; was not traced, insert values: (setf (tracing-heads tracer) (cons (list head-functor redo-functor org-clauses) (tracing-heads tracer) ))))) (defun tracer-get-org-clauses (head-functor) ;; value: list of untraced clauses (get-el (("head-functor" "redo-functor" org-clauses)) (member head-functor (tracing-heads tracer) :key #'car :test #'equal))) (defun tracer-get-redo-functor (head-functor) ;; value: the redo functor/SA (get-el (("head-functor" redo-functor "org-clauses")) (member head-functor (tracing-heads tracer) :key #'car :test #'equal))) (defun trace-or-retrace-procedure (functor incl excl print-p print-f) ;; Destruct. modifies the database (let ((redo-sym (traced-p functor))) (if redo-sym (retrace-procedure functor redo-sym incl excl print-p print-f) (trace-procedure functor incl excl print-p print-f) ))) (defun trace-procedure (functor incl excl print-p print-f) ;; Destruct. modifies the database. ;; Replaces old clauses of procedure by clauses ;; modified for tracing. ;; Condition on entry: is not traced. ;; Value: list of clauses (unmodified) (or nil on error). (let ((default-action (get-default-action incl excl))) (if (null default-action) (progn (rf-princ-like-lisp (format nil "Do not use both of -incl and -excl." )) nil ) (do* ((rest-clauses (member functor (get-database) :key #'caadr :test #'equal ) (member functor (cdr rest-clauses) :key #'caadr :test #'equal )) (traced-clauses nil (cons clause traced-clauses)) (clause (car rest-clauses) (car rest-clauses)) (i 1 (1+ i)) (action (or (get-incl-or-excl i incl excl) default-action) (or (get-incl-or-excl i incl excl) default-action) ) (redo-sym (create-redo-functor functor)) ) ((null rest-clauses) (if (null traced-clauses) ;; functor not found: (progn (rf-princ-like-lisp "Procedure not found: ") (pp functor) nil ) (let ((org-clauses (reverse traced-clauses))) (tracer-book-keeping functor redo-sym org-clauses) (append-redo-and-fail-clauses (create-redo-clauses org-clauses redo-sym) functor redo-sym ) org-clauses ))) (setf (car rest-clauses) (create-traced-clause clause clause i redo-sym action print-p print-f )))))) (defun retrace-procedure (functor redo-sym incl excl print-p print-f) ;; destruct. modifies the database. ;; Replaces old clauses of procedure by clauses ;; modified for tracing. ;; Condition on entry: functor is traced. ;; Value: void (do* ((rest-clauses (member functor (get-database) :key #'caadr :test #'equal ) (member functor (cdr rest-clauses) :key #'caadr :test #'equal )) (clause (car rest-clauses) (car rest-clauses)) (org-clauses (tracer-get-org-clauses functor) (cdr org-clauses)) (org-clause (car org-clauses) (car org-clauses)) (i 1 (1+ i)) ) ((null rest-clauses)) (setf (car rest-clauses) (create-traced-clause clause org-clause i redo-sym (get-incl-or-excl i incl excl) print-p print-f )))) (defun untrace-procedure (functor) (remove-redo-and-fail-clauses functor) (do* ((rest-clauses (member functor (get-database) :key #'caadr :test #'equal ) (member functor (cdr rest-clauses) :key #'caadr :test #'equal )) (clause (car rest-clauses) (car rest-clauses)) (org-clauses (tracer-get-org-clauses functor) (cdr org-clauses) ) (org-clause (car org-clauses) (car org-clauses)) ;; may be the database has been destroyed: (still-traced-p (eq (tracing-id tracer) (get-el ("hn-or-ft" "head" body-1 . "body-rest") clause ))) ) ((or (null rest-clauses) (null org-clauses) (not still-traced-p)) (setf (tracing-heads tracer) (remove functor (tracing-heads tracer) :key #'car :test #'equal )) t ) ;; replace a traced clause: (setf (car rest-clauses) org-clause) )) (defun create-traced-clause (db-clause org-clause clause-n redo-sym incl-excl-nil print-p print-f) ;; returns a traced version of org-clause or db-clause (if (eq (tracing-fail-id tracer) (get-el ("tag" "head" body-1 . "body-rest") db-clause) ) ;; found an old fail clause: db-clause (case incl-excl-nil ((nil) db-clause) (incl (create-incl-clause org-clause clause-n redo-sym print-p print-f) ) (excl (create-excl-clause org-clause)) (t (error "Internal error in create-traced-clause.")) ))) (defun create-excl-clause (clause) ;; returns a traced version of clause (printing disabled) (let+ (((tag head . body) clause)) (list* tag head (tracing-id tracer) body) )) (defun create-incl-clause (clause clause-n redo-sym print-p print-f) ;; returns a traced version of clause (printing enabled) (let*+ (((hn-or-ft (functor . arguments) . body) clause) (bar-in-head-p (member '\| arguments)) (arity (if bar-in-head-p (1- (length arguments)) (length arguments))) ((vari-foot vari-head vari-redo-p vari-print-flag . new-head-arguments) (create-variables (+ 4 arity ) '(1) (collect-variables clause)) ) (new-head (if bar-in-head-p `(,functor ,@(butlast new-head-arguments) \| ,@(last new-head-arguments) ) `(,functor ,@new-head-arguments) )) (vari-foot-or-nil (if (eq 'hn hn-or-ft) nil (list vari-foot))) (the-tracing-id-line (tracing-id tracer)) (the-redo-line `(is ,vari-redo-p (once (tracer_get_redo_p ,clause-n ,(inst-functor-for-call redo-sym) (inst ,new-head) )))) (the-unification-line `(is ,vari-head (is ,new-head (inst (,functor ,@arguments)))) ) (the-print-flag-line (if (or (eq 'true print-p)) ;; no print-predicate given: `(is ,vari-print-flag ,print-p) ;; print-predicate given: `(tracer_get_print_flag ,vari-head ,print-p ,vari-print-flag ))) (the-print-function (if (eq 'true print-f) ;; use default print-function: 'tracer_default_printer print-f )) (the-print-enter-line `(tracer_print_enter ,vari-head ,clause-n ,vari-redo-p ,vari-print-flag ,the-print-function ,hn-or-ft )) (the-body-line (prepare-body hn-or-ft vari-head body clause-n vari-foot vari-print-flag the-print-function )) (the-print-exit-line `(tracer_print_exit ,vari-head ,clause-n ,vari-print-flag ,the-print-function ,@(if (eq 'hn hn-or-ft) nil `((inst (the_foot ,@vari-foot-or-nil))) ) )) ) `(,hn-or-ft ,new-head ,the-tracing-id-line ,the-redo-line ,the-unification-line ,the-print-flag-line ,the-print-enter-line ,@the-body-line ,the-print-exit-line ,@vari-foot-or-nil ))) (defun create-variables (n varnuml oldvars) "Returns a list of new variables (not contained in oldvars)." (if (zerop n) nil (let ((var-as-number (car (nextnew varnuml oldvars)))) (cons (legnumvar (list var-as-number)) (create-variables (1- n) (list (1+ var-as-number)) oldvars) )))) (defun create-redo-functor (functor) "Returns functor used for redo-clauses." (if (symbolp functor) (make-symbol (stringcat (princ-to-string functor) "_redo_p" )) (let ((head-symbol (get-symbol-of-call functor))) ;; make-symbol returns an uninterned symbol (Steele p.244) (subst (make-symbol (stringcat (princ-to-string head-symbol) "_redo_p" )) head-symbol functor :test #'eq )))) (defun create-redo-clauses (list-of-clauses redo-sym) ;; list-of-clauses contains all clauses of a procedure. ;; Value: list of redo-clauses. (let* ((clause-n 0) (list-of-redo-clauses (mapcar #'(lambda (clause) (let* ((new-variables (create-variables 1 '(1) (collect-variables clause) )) (vari-clause-n (first new-variables)) ) (incf clause-n) `(hn ; (cadr clause) = head (,redo-sym ,vari-clause-n ,(cadr clause)) ;(rf-print "--------------->") ;(rf-print ,clause-n) (> ,vari-clause-n ,clause-n) ))) list-of-clauses ))) (append list-of-redo-clauses `((ft (,redo-sym id id) false)) ))) (defun get-symbol-of-call (call) "Returns the symbol that would be printed at first by the PROLOG-pretty-printer." (if (symbolp call) call (get-symbol-of-call (car call)) )) (defun prepare-body (hn-or-ft vari-head factors clause-n vari-foot print-flag print-f) ;; insert a message to be displayed when running from the right over a cut. ;; Save the foot in a variable. (let ((body nil) cut-at-the-end-p ) (dolist (factor factors) (if (eq '\! factor) (setq body (list* `(tracer_cut_message ,vari-head ,clause-n ,print-flag ,print-f) '! ; body will be reversed body) cut-at-the-end-p t ) (setq body (cons factor body) cut-at-the-end-p nil ))) (when (eq 'ft hn-or-ft) ;; prepare foot: (if cut-at-the-end-p (setf (third body) `(is ,vari-foot ,(third body))) ; destructive (setf (first body) `(is ,vari-foot ,(first body))) )) (reverse body) )) (defun get-default-action (incl excl) ;; default action if for first call of trace: (cond ((and (null incl) (null excl)) 'incl ) ((and incl excl) nil ) ; this is an error (incl 'excl ) (t 'incl ))) (defun get-incl-or-excl (clause-n incl excl) ;; Value is one of {incl, excl, nil} (cond ((membership clause-n excl) 'excl) ((membership clause-n incl) 'incl) (t 'nil) )) (defun membership (item list-or-all) (if (eq 'all list-or-all) t (member item list-or-all) )) (defun inst-functor-for-call (functor) (if (symbolp functor) functor (list 'inst functor) )) (defun append-redo-and-fail-clauses (redo-clauses functor redo-sym) ;; Extends the database by appending the redo-clauses and ;; appending a clause with head matching all calls. (let ((vari-head-args (if (symbolp functor) (legnumvar '(1)) (first (create-variables 1 '(1) (collect-variables functor))) )) (big-number (length redo-clauses)) ) ; = 1 + nr of clauses of functor (set-database (append (get-database) redo-clauses `((hn ; the fail clause (,functor \| ,vari-head-args) ;; args of tracer_print_fail: ;; functor redo-p print-p print-f ,(tracing-fail-id tracer) (tracer_print_fail (inst (,functor \| ,vari-head-args)) ;;t (once (,(inst-functor-for-call redo-sym) ,big-number (inst (,functor \| ,vari-head-args))) ) true tracer_default_printer) unknown )) )))) (defun remove-redo-and-fail-clauses (head-functor) ;; removes the redo- and fail-clauses for head-functor from database. ;; It does not matter if head-functor is not a traced procedure. (let ((redo-functor (traced-p head-functor))) (when redo-functor ;; it is a traced procedure: (set-database (remove-if #'(lambda (clause) (let+ ((("tag" (head-f . "head-args") body-1 . "body-rest") clause )) (or (equal head-f redo-functor) ; rem. redo-clause (and (equal head-f head-functor) ; rem. fail-clause (eq body-1 (tracing-fail-id tracer)) )))) (get-database) ))))) (defun tracer-cps (term) ;; copies a structure ;;(get-el ("inst" head) (tracer-copy-vars-aux term)) (tracer-copy-vars-aux term) ) (defun tracer-copy-vars-aux (term) ;; Returns a copy of term with fresh vars. (cond ((atom term) term ) ((vari-t term) (list 'vari (gentemp) 1) ) (t (cons (tracer-copy-vars-aux (car term)) (tracer-copy-vars-aux (cdr term))) ))) ;; ---------------------------------------------------------------------------- (defconstant tracer-min-space 30 "stop indenting if less space then this") (defun tracer-print-heading (string) ;; Example: (tracer-print-heading "> ") ;; Returns the cursor-pos. ;; Indentation is controlled by the trace level (let ((spaces-n (tracer-get-indent)) indent-as-str ) (if (< (- *rf-print-width* spaces-n) tracer-min-space) ;; no further indenting because of missing space: (progn (setq spaces-n (- *rf-print-width* tracer-min-space)) (setq indent-as-str (format nil "[~D]" (tracing-level-now tracer))) (rf-princ-like-lisp indent-as-str) (spaces (- spaces-n (length indent-as-str))) ) (spaces spaces-n) ) (rf-princ-like-lisp string) (+ spaces-n (length string)) )) (defun tracer-print-hn-or-ft (hn-or-ft-or-ft-exit cursor-pos) ;; Prints ":-" or ":- &" or ":-&" ;; Returns new cursor position (let* ((str (case hn-or-ft-or-ft-exit (hn " :- ") (ft " :- & ") (ft-exit " :-& ") (hn-exit " :- ") (t (error "Error in tracer.lsp (tracer-print-hn-or-ft).")) )) (len (length str)) ) (rf-princ-like-lisp str) (+ cursor-pos len) )) (defun tracer-print-head (indent head &optional clause-n) ;; Value: cursor-pos (when clause-n (incf indent 4) (rf-princ-like-lisp clause-n) (rf-princ-like-lisp " ") ) (if (eq *style* 'lisp) (progn (pp-init indent) (pp-expr head) (1+ pp-currentpos*) ) (pro-print-head head indent) )) (defun tracer-print-foot (cursor-pos foot) (if (eq *style* 'lisp) (tracer-print-foot-lsyn (tracer-get-indent) cursor-pos foot ) (tracer-print-foot-psyn (tracer-get-indent) cursor-pos foot )) (rf-terpri) ) (defun tracer-print-foot-lsyn (left-margin cursor-pos foot) (let ((rest-col (- *rf-print-width* cursor-pos 3)) ;3: safety (cursor-start cursor-pos) ) (when (and (< rest-col tracer-min-space) (> (flatsize foot) rest-col) ) (setq cursor-start (+ 5 left-margin)) (pro-newline-and-indent cursor-start) ) (pp-init cursor-start) (pp-expr foot) )) (defun tracer-print-foot-psyn (left-margin cursor-pos foot) (pro-print* (list 'inst foot) cursor-pos (+ 5 left-margin) tracer-min-space)) (defun tracer-get-indent () (* 2 (1- (tracing-level-now tracer)))) ;; ---------------------------- r f i - c o m m a n d s ------------------ (defun rfi-cmd-trace (userline) ;; userline = (trace ..) ;; Transformation from P-syntax to L-syntax has been done. (when (null (get-sysbase 'tracebase)) (rfi-load-tracer) ) (unless (null (get-sysbase 'tracebase)) (if (= 1 (length userline)) (tracer-print-status) (cond ((eq '-rest (cadr userline)) (rfi-cmd-trace-rest userline)) ;; trace those procedures not yet traced at all, SA ((eq '-all (cadr userline)) (rfi-cmd-trace-all userline)) ;; trace all clauses of all procedures in rfi-database, SA (t (rfi-cmd-trace-many-defs (cdr userline))))))) (defun rfi-cmd-trace-rest (userline) ;; trace those procedures not yet traced at all, SA (unless (null (cddr userline)) (rf-princ-like-lisp "After `-rest' no more arguments are considered")) (let* ((all-procs (remove-if #'vari-t (operators))) (redo-functors (mapcar #'tracer-get-redo-functor all-procs))) (do* ( (all-procs all-procs (cdr all-procs)) (clause (car (member (car all-procs) (get-database) :key #'caadr :test #'equal )) (car (member (car all-procs) (get-database) :key #'caadr :test #'equal ))) (body-1 (third clause) (third clause))) ((null all-procs) nil) (unless (or (eq (tracing-id tracer) body-1) (eq (tracing-fail-id tracer) body-1) (member (car all-procs) redo-functors)) (trace-procedure (car all-procs) 'all nil 'true 'true))))) (defun rfi-cmd-trace-all (userline) ;; trace all clauses of all procedures in rfi-database, SA (unless (null (cddr userline)) (rf-princ-like-lisp "After `-all' no more arguments are considered")) ;; untrace all: (mapc #'untrace-procedure (mapcar #'car (tracing-heads tracer)) ) ;; trace all: (do ((heads (remove-if #'vari-t (operators)) (cdr heads))) ((null heads) nil) (trace-procedure (car heads) 'all nil 'true 'true))) (defun rfi-cmd-trace-many-defs (many-defs) (let ((first-proc (rfi-cmd-trace-0 many-defs t))) (if (null first-proc) nil (progn (rfi-cmd-trace-one-def first-proc) (rfi-cmd-trace-many-defs (nthcdr (length first-proc) many-defs )))))) (defun rfi-cmd-trace-one-def (one-def) ;; e.g. one-def = (facrel -incl 1 2 -excl 3 4) (let ((incl (rfi-cmd-trace-1 one-def '-incl nil)) (excl (rfi-cmd-trace-1 one-def '-excl nil)) (print-p (rfi-cmd-trace-1 one-def '-print-p 'true)) (print-f (rfi-cmd-trace-1 one-def '-print-f 'true)) ) (if (and (null incl) (null excl)) (trace-or-retrace-procedure (car one-def) 'all nil print-p print-f) (trace-or-retrace-procedure (car one-def) incl excl print-p print-f)))) (defun rfi-cmd-trace-0 (many-defs last-arg-was-keyword-p) ;; many-defs = {proc-1 ..} ;; Value: list for first procedure (cond ((null many-defs) nil ) ((rf-keywordp (car many-defs)) (cons (car many-defs) (rfi-cmd-trace-0 (cdr many-defs) t) )) (last-arg-was-keyword-p (cons (car many-defs) (rfi-cmd-trace-0 (cdr many-defs) nil)) ) ((numberp (car many-defs)) (cons (car many-defs) (rfi-cmd-trace-0 (cdr many-defs) nil)) ) (t ;; start of a new proc. nil ))) (defun rfi-cmd-trace-1 (one-def keyword default) (let ((m (member keyword one-def))) ; e.g. m = (-incl 1 2 3 ) (if m (case (car m) ((-incl -excl) (rfi-cmd-trace-2 (cdr m)) ) ((-print-p -print-f) (second m) ) (t (error "Unknown keyword in rfi-cmd-trace-1: " keyword) )) default ))) (defun rfi-cmd-trace-2 (a-list) ;; collect a list of integers (or the symbol ALL) (cond ((null a-list) nil ) ((eq 'all (car a-list)) 'all ) ((numberp (car a-list)) (cons (car a-list) (rfi-cmd-trace-2 (cdr a-list))) ) (t nil) )) (defun rfi-cmd-untrace (userline) ;; userline = untrace {head-functor} ;; Transformation to P-syntax has been done. (if (null (cdr userline)) ;; untrace all: (mapc #'untrace-procedure (mapcar #'car (tracing-heads tracer)) ) ;; untrace selected: (mapc #'untrace-procedure (cdr userline)) )) (pushnew :rf-tracer *features*) ;; ---------------------------------------------------------------------------- #| (load "/home/herfert/lisp/tracer.lsp") (defun ppp (list-of-clauses) ; pretty print prolog, for testing only (rf-terpri) (let ((*style* 'prolog)) (dolist (clause list-of-clauses 'okay) ;;(rf-terpri) (pp clause) ))) (pro-print (create-traced-clause '(hn (p (f (vari x)) (g (vari y))) b1 b2) 1 'p_redo 'true 'true )) (progn (mapc #'(lambda (clause) (terpri) (pro-print clause) ) (create-redo-clauses '((hn (p (f (vari x)) (g (vari y))) b1 b2) (hn (p (h (vari z)) (vari r))) ) 'tracer_p_redo )) 'okay ) (progn (set-database (copy-tree rfi-db)) (ppp (trace-procedure 'facrel)) (ppp (get-database)) ) |# ;;;### eof ;;;### File "comment.lisp" ;;; Copyright Notice ;;; ;;; This software is distributed for non-profit and research purposes only. ;;; 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. ;;; ;;; Michael Herfert, 1992 ;;; -------------------------------------------------------------------------- ;;; ;;; Module comment.lsp. ;;; ;;; Contains functions to read and print comments ;;; of Relfun-programs. ;;; If L-syntax is active then comments are recognized by two ;;; read-macros. ;;; If P-syntax is active then comments are recognized by the scanner. (defvar *comment-style* nil "Controls reading and printing. If nil then comments are ignored. If not nil then it is a list describing how to print comments: *comment-style* = (

) is in the range 0..*rfi-print-width*. is a symbol describing how to format end-of-line-comments: RAW no special formatting COMMENT-COLUMN align to . COMMENT-COLUMN-OR-MARGIN align to . If not possible align to right margin MARGIN align to right margin is a symbol describing how to format begin-of-line-comments: BREAK break lines if longer then *rfi-print-width* NO-BREAK never break lines even if a line exceeds the right margin. See also function translate-file. ") (defvar *default-comment-style* '(40 comment-column-or-margin break)) (defconstant lsyn-comment-lead-in #\;) (defconstant psyn-comment-lead-in #\%) (defconstant com-max-depth 2) (defstruct com-cell lisp ; expr to print before the comment (pre-txt "") ; comments before lisp (seldom used) (post-txt "") ; comments after lisp (the usual case) ;; If post-txt begins with a #\newline then it's a begin-of-line-comment, ;; otherwise the first substring (up to the first #\newline) is a ;; end-of-line-comment. ;; If post-txt is not the empty string it is terminated by #\newline. ;; post-txt is printed after lisp. internal-p ; lisp contains a coment ) (defmacro look-for-comment () ;; Checks if the scanner holds a comment. `(make-com-cell :post-txt (if (funcall scanner 'comment-p) (funcall scanner 'comment) "")) ) (defun comment-p (sexpr) ;; <==> sexpr is a com-cell containing a non-empty comment. (or (and (com-cell-p sexpr) (or (string/= "" (com-cell-pre-txt sexpr)) (string/= "" (com-cell-post-txt sexpr)) )) (and (pro-expr-p sexpr) (or (string/= "" (pro-expr-pre-txt sexpr)) (string/= "" (pro-expr-post-txt sexpr)) )))) (defun get-comment-lead-in () (if (eq *style* 'lisp) lsyn-comment-lead-in psyn-comment-lead-in )) ;;; ------------------------------------------------------------------------- ;;; ;;; Reading Commments ;;; ;;; ------------------------------------------------------------------------- (defun eat-comment-lead-ins (the-input-stream com-lead-in) ;; reads all comment-lead-in characters from the input stream. ;; On exit (read-char the-input-stream) returns the first char ;; after the last com-lead-in. ;; No value. (do ((ch (peek-char nil the-input-stream nil eof-char) (peek-char nil the-input-stream nil eof-char) )) ((char/= com-lead-in ch)) (read-char the-input-stream) ; consume the com-lead-in )) (defun read-until-newline (the-input-stream) "Reads the rest of the line including the newline-char. On exit (read-char the-input-stream) returns the first char after #\newline. " (do* ((ch (read-char the-input-stream nil #\newline) (read-char the-input-stream nil #\newline) ) (txt (string ch) (stringcat txt (string ch)) ) ) ((char= ch #\newline) txt ) ) ) (defun read-until-non-white (the-input-stream) "Read until the first non-white-space char or eof-char in the current line. #\newline is not a whitespace. On entry the (imag.) cursor is in the first column. Returns a list: (

) On exit the next call of (read-char the-input-stream) returns the non-white char. " (do ((ch (peek-char nil the-input-stream nil eof-char) (peek-char nil the-input-stream nil eof-char) ;; peek-char

;; (Steele p574) ) (column 1 (1+ column)) ) ((case ch ((#\space #\tab) nil ) ; continue reading (t t)) ; non-white found (list ch column) ) (read-char the-input-stream) ; consume the white-space )) (defun read-until-black (the-input-stream) "Reads until a non-white-space. #\newline is a whitespace. On exit (read-char the-input-stream) returns the non-white char. Value is a list: ( ) str is a string containing a #\newline for every read #\newline. " (do ((non-white-char (first (read-until-non-white the-input-stream)) (first (read-until-non-white the-input-stream)) ) (str "" (stringcat str (string #\newline))) ) ((char/= #\newline non-white-char) (list non-white-char str) ) (read-char the-input-stream) ; consume the #\newline )) (defun read-comments (com-lead-in type-of-first-com ; dom = {1, 2} the-input-stream ) "Read in comments until a non-comment. Empty lines are parts of the comment. Returns a list: (

) If type-of-first-com = 2 then has a leading #\newline. On entry (read-char the-input-stream) returns the first char after the (first) comment lead in. On exit the next call of (read-char the-input-stream) returns the first char that is not part of a comment resp. eof. " (eat-comment-lead-ins the-input-stream com-lead-in) (do* ((txt (read-until-newline the-input-stream) (stringcat txt (read-until-newline the-input-stream)) ) (list-2 (read-until-non-white the-input-stream) (read-until-non-white the-input-stream) ) (non-white-char (first list-2) (first list-2)) (column (second list-2) (second list-2)) (nr-of-newlines 1 (1+ nr-of-newlines)) ) ((and (char/= non-white-char com-lead-in) (char/= non-white-char #\newline) ) (list (if (= 2 type-of-first-com) (stringcat (string #\newline) txt) txt) nr-of-newlines column ) ) (when (char= non-white-char com-lead-in) ;; consume the com-lead-in: (eat-comment-lead-ins the-input-stream com-lead-in)) )) (defun lsyn-comment-type-1-reader (stream comment-lead-in) "Reader-macro. Called for lines of the format: ; Reads the comment and all comments immedeatly following this line. " (declare (ignore comment-lead-in)) (make-com-cell :post-txt (first (read-comments lsyn-comment-lead-in 1 stream)) )) (defun lsyn-comment-type-2-reader (stream the-newline-char) "Reader-macro. Called at the end of the line to check if the next line begins with a comment. If so it reads the comments and all comments immedeatly following this line. " (declare (ignore the-newline-char)) (let ((non-white-char (first (read-until-non-white stream)))) (cond ((char= lsyn-comment-lead-in non-white-char) ;; comment detected: (read-char stream) ; consume the comment-lead-in (make-com-cell :post-txt (first (read-comments lsyn-comment-lead-in 2 stream)))) ;;((char= #\newline non-white-char) ;; empty line without comment-leadin detected: ;;(read-char stream) ; consume the comment-lead-in ;;#\newline ) (t ;; no comment: (values) ; return no values )))) ;; ------------------------------------------------------------------------- (defun hide-comment-at-first (the-list) ;; the-list begins with a comment. ;; Returns a list. (let* ((el-1 (first the-list)) (el-2 (second the-list)) ;(el-3 (third the-list)) (result-of-2 (hide-comments el-2)) ) (if (com-cell-p result-of-2) ;; el-2 has an internal comment: (setf (com-cell-lisp el-1) (com-cell-lisp result-of-2) (com-cell-internal-p el-1) t ) ;; el-2 has no internal comment: (setf (com-cell-lisp el-1) result-of-2) ) (setf (com-cell-pre-txt el-1) (com-cell-post-txt el-1) (com-cell-post-txt el-1) "" ) (cons el-1 (hide-comments-in-list (cddr the-list))) )) (defun hide-comments-in-list (the-list &aux (the-car (car the-list))) ;; the-list can begin with a comment but not with a tag. ;; Returns a list. ;; Example: (

) ;; ==> (

) ;; is now in the lisp-field of . ;;(terpri) (princ "hide-comments-in-list: the-list = ") (princ the-list) (cond ((null the-list) nil ) ((com-cell-p the-car) ;; the-list begins with a comment: (hide-comment-at-first the-list) ) (;;(or (eq 'hn the-car) (eq 'ft the-car) (eq '\| the-car) ) (member the-car '(hn ft uc \| !)) ;; never comment a tag or a bar: (cons the-car (hide-comments-in-list (rest the-list))) ) (t ;; no comment, no tag: (let ((el-2 (second the-list))) (if (com-cell-p el-2) ;; comment on second position: (let ((res-of-first (hide-comments (first the-list)))) (if (com-cell-p res-of-first) ;; the car of the-list has an internal comment: (setf (com-cell-lisp el-2) (com-cell-lisp res-of-first) (com-cell-internal-p el-2) t ) ;; the car of the list has no internal comment: (setf (com-cell-lisp el-2) res-of-first )) (cons (second the-list) (hide-comments-in-list (cddr the-list)) )) ;; no comment on second position: (cons (hide-comments (first the-list)) (hide-comments-in-list (cdr the-list)) ) ))))) (defun hide-comments (expr) "Merges sexpr-s and comments. If expr is a list and one of its element is a comment, the whole expr will be packed in a com-cell." (if (atom expr) expr ;; expr is a list: (let ((result (hide-comments-in-list expr))) (if (any-true-p result #'com-cell-p) ;; at least one element has a comment: (lift-comments (make-com-cell :internal-p t :lisp result)) ;; no element contains a comment: result )))) (defun pack-comments (expr) "Sets up the internal-p flag and creates com-cells in expressions containing com-cells." (cond ((com-cell-p expr) (let ((result (pack-comments (com-cell-lisp expr)))) (make-com-cell :lisp result :pre-txt (com-cell-pre-txt expr) :post-txt (com-cell-post-txt expr) :internal-p (com-cell-p result) ))) ((consp expr) (let ((result (mapcar #'pack-comments expr))) (if (any-true-p result #'com-cell-p) ;; at least one element has a comment: (make-com-cell :internal-p t :lisp result) ;; no element contains a comment: result ))) (t expr ))) ;;; ------------------------------------------------------------------------- ;;; ;;; Printing Commments ;;; ;;; ------------------------------------------------------------------------- (defun gen-n-spaces (n) (do ((i 0 (1+ i)) (spaces "" (stringcat spaces " ")) ) ((= i n) spaces ))) (defun gen-n-newlines (n) (do ((i 0 (1+ i)) (newlines "" (stringcat newlines (string #\newline))) ) ((= i n) newlines ))) (defun find-newline (str start-pos) ;; Returns the position of the first #\newline. ;; Starts search at start-pos. ;; There must be a newline. (do ((i start-pos (1+ i)) ) ((char= #\newline (char str i)) i ))) (defun get-next-word (str start-pos) ;; Returns a list of two integers: ;; (

) ;; If there is no word after start-pos or a #\newline is detected ;; then nil is returned. ;; str must contain at least one #\newline. ;; Words are delimited by blanks. ;; start-pos is numbered from zero. (if (>= start-pos (length str)) nil (let* ((start-of-word (do ((i start-pos (1+ i))) ; find non-white-char ((case (char str i) ((#\space #\tab) nil ) ; continue loop (#\newline (return -1) ) ; abort loop, no word (t (return i) ))) )) ; abort loop, word found ) (if (= start-of-word -1) nil ; no word (do ((end-of-word start-of-word (1+ end-of-word))) ((case (char str (1+ end-of-word)) ((#\space #\tab #\newline) ;; abort loop: t ) (t ;; continue loop: nil )) (list start-of-word end-of-word) )))))) (defun print-one-line-of-comment (str leading-spaces beg-end-of-first-word cursor-col indent-col com-lead-in ) ;; Prints str (str must be terminated by #\newline), possibly on multiple ;; lines. ;; Every new line begins with a number of leading spaces, determined ;; by leading-spaces. ;; Prints at least the first word of str. ;; There must be at least one word in str. ;; On exit the cursor is after the last printed character. ;; No value. (do* ((beg-end-of-word beg-end-of-first-word) (beg-of-word (first beg-end-of-first-word) (first beg-end-of-word)) (spaces-before-word leading-spaces (subseq str (1+ end-of-word) beg-of-word)) (end-of-word (second beg-end-of-first-word) (second beg-end-of-word)) (the-word (stringcat spaces-before-word (subseq str beg-of-word (1+ end-of-word)) ) (stringcat spaces-before-word (subseq str beg-of-word (1+ end-of-word)) )) (new-cursor-col (+ cursor-col (length the-word)) (+ new-cursor-col (length the-word)) ) ) ((and (> new-cursor-col *rf-print-width*) ; last column reserved ; first word extra: (not (eq beg-end-of-word beg-end-of-first-word)) ) ;; no space on this line but words to print left: (pro-newline-and-indent indent-col) (rf-princ-like-lisp com-lead-in) ;; print the rest words: (print-one-line-of-comment str leading-spaces beg-end-of-word (+ 1 indent-col) ; 2 = len(";") indent-col com-lead-in ) ) (rf-princ-like-lisp the-word) (setq beg-end-of-word (get-next-word str (1+ end-of-word))) (when (null beg-end-of-word) ;; no more words: (return) ))) (defun print-one-line-of-comment-wo-break (str str-start-pos) ;; Prints str from str-start-pos up to the first #\newline (must exist) ;; even if it exceeds *rfi-print-width* (rf-princ-like-lisp (subseq str str-start-pos (find-newline str str-start-pos)))) (defun print-comment-type-1 (str-wo-newline lead-in-char cursor-col indent-col) ;; Try to print the comment at the current line. ;; If this is not possible print as type 2. ;; On exit the cursor is on the right of the last printed character. ;; No value. (let* ((len-of-com (length str-wo-newline)) (space-on-line (- *rf-print-width* cursor-col)) (real-space-after-indent-col (- *rf-print-width* (max (first *comment-style*) cursor-col ))) ) (if (<= space-on-line (+ 2 len-of-com)) ; 2 = len("; ") ;; does not fit on line: (progn (pro-newline-and-indent indent-col) (print-comment-type-2 (stringcat str-wo-newline (string #\newline)) 0 ; str-start-pos lead-in-char indent-col) ) ;; comment fits on line: (case (second *comment-style*) (raw ;; no alignment at all. (rf-princ-like-lisp " ") (rf-princ-like-lisp lead-in-char) (rf-princ-like-lisp str-wo-newline) ) (comment-column ;; indent to comment-column, if possible. (if (> real-space-after-indent-col len-of-com) ;; alignment possible ==> go to indent-column (spaces (- (first *comment-style*) cursor-col)) ;; no alignment poss.: (rf-princ-like-lisp " ") ) (rf-princ-like-lisp lead-in-char) (rf-princ-like-lisp str-wo-newline) ) (comment-column-or-margin ;; indent to indent-column, if possible, else align to right. (if (> real-space-after-indent-col len-of-com) ;; align to indent-column: (spaces (- (first *comment-style*) cursor-col)) ;; align to right margin: (spaces (- *rf-print-width* cursor-col len-of-com 1)) ) (rf-princ-like-lisp lead-in-char) (rf-princ-like-lisp str-wo-newline) ) (margin ;; always align to right: (spaces (- *rf-print-width* cursor-col len-of-com 1)) (rf-princ-like-lisp lead-in-char) (rf-princ-like-lisp str-wo-newline) ) (t (error "Internal error in ") ))))) (defun print-comment-type-2 (str str-start-pos com-lead-in indent-col) "Prints str (from str-start-pos) up to the first #\newline (must exist). On entry cursor is in indent-col. On exit cursor is on the right of the last printed character. " (let* ((beg-end-of-first-word (get-next-word str str-start-pos)) (beg-of-first-word (first beg-end-of-first-word)) ;;(end-of-first-word (second beg-end-of-first-word)) ) (unless (null beg-end-of-first-word) ;; comment not empty: (rf-princ-like-lisp com-lead-in) (if (eq 'break (third *comment-style*)) ;; break comment-lines if longer then *rfi-print-width*: (print-one-line-of-comment str (gen-n-spaces (- beg-of-first-word str-start-pos )) beg-end-of-first-word (+ 1 indent-col) ; 1 = len(";") indent-col com-lead-in ) (print-one-line-of-comment-wo-break str str-start-pos) )))) (defun print-comment (str lead-in-char cursor-col indent-col) "str contains comments each terminated by a #\newline. Prints all comments. The last #\newline is not printed. On exit cursor is on the right of the last printed character. " (let ((start-of-type-2 1) ; pos. 0: #\newline (len-of-str (length str)) ) (unless (char= #\newline (char str 0)) ;; starts with a end-of-line-comment: (print-comment-type-1 (subseq str 0 (find-newline str 0)) lead-in-char cursor-col indent-col ) (setq start-of-type-2 (1+ (find-newline str 0))) ) ;; all other comments are of type 2: (do ((i start-of-type-2 (1+ (find-newline str i))) ) ((= i len-of-str) ;; all comments printed: indent-col ) ;; print one line of comment: (pro-newline-and-indent indent-col) (print-comment-type-2 str i lead-in-char indent-col) ))) (defun lsyn-comment-printer (com cursor-col indent-col &optional clause-p) ;; type(com) = com-cell ;; clause-p <==> called from pp-clause ;; On exit cursor is on the right of the last printed character. (unless (string= "" (com-cell-pre-txt com)) ;; print a leading comment (always type 2): (print-comment-type-2 (com-cell-pre-txt com) (if (char= #\newline (char (com-cell-pre-txt com) 0)) 1 0) lsyn-comment-lead-in cursor-col ) (pro-newline-and-indent indent-col) ) (if (com-cell-internal-p com) ;; Comment inside lisp-part: (if clause-p (pp-big-clause (com-cell-lisp com)) (pp-broken-list (com-cell-lisp com) round-left round-right )) ;; no internal comment: (if clause-p (pp-clause (com-cell-lisp com)) (pp-expr (com-cell-lisp com)) )) (unless (string= "" (com-cell-post-txt com)) ;; print the comment: ;;(princ pp-currentpos*) (print-comment (com-cell-post-txt com) lsyn-comment-lead-in (1+ pp-currentpos*) indent-col ) ;; After a comment a closing parenthese requires a new line: (push 'comment-was-here pp-stack*) ; pp-push replaced by push (MS/MP) )) ;;; ------------------------------------------------------------------------- ;;; ;;; Auxilliary functions ;;; ;;; ------------------------------------------------------------------------- (defun apply-and (list-of-bool) "<==> all elements are non-nil" (or (null list-of-bool) (and (car list-of-bool) (apply-and (cdr list-of-bool)) ))) ;; rename to (defun any-true-p (the-list &optional #-CLiCC (pred #'(lambda (x) x)) #+CLiCC (pred nil)) ; needed for CLiCC optimizer problem ;; Returns nil, if all elements evaluate to nil under pred. ;; Else it returns the first element not evaluating to nil. (do* ((rest-of-list the-list (rest rest-of-list)) (element (first rest-of-list) (first rest-of-list)) ) ((null rest-of-list) ;; all nil nil ) (when (funcall pred element) (return element) ))) (defun extract-atoms-by-predicate (tree pred) "Returns a list of the atoms that satisfies the pred." (cond ((null tree) nil ) ((consp tree) (append (extract-atoms-by-predicate (car tree) pred) (extract-atoms-by-predicate (cdr tree) pred) )) ;; tree is an atom : ((funcall pred tree) (list tree) ) (t nil ))) (defun setup-comment-readtable (a-readtable) ;; Sets read-macros for #\; and #\newline. ;; a-readtable is not destructively modified. ;; Value: The new readtable. (let ((new-readtable (copy-readtable a-readtable))) (set-macro-character lsyn-comment-lead-in #'lsyn-comment-type-1-reader nil ; non-terminating-p new-readtable ) (set-macro-character #\newline #'lsyn-comment-type-2-reader nil ; non-terminating-p new-readtable ) new-readtable )) ;;; ------------------------------------------------------------------------- ;;; ;;; Functions to extract/insert comments. ;;; ;;; ------------------------------------------------------------------------- (defun rf-tag-p (symbol) (or (member symbol '(hn ft uc is inst vari tup ! \|) ) (lisp-function-p symbol) )) ;;; Manage a table to associate symbols with values: ;;; ------------------------------------------------ ;; Alternative implementation via hash tables is possible. (defun com-set-field (table vari field value) "Set the field of vari to the given value. If vari is not in table it will be inserted. Field is one of {org-symbol, depth, comment, toplevel}. Return the modified table." (let* ((pair (assoc vari table)) (tuple (if pair (cdr pair) (list nil 0 "" "") )) (new-table (if pair table (acons vari tuple table) )) ) ;; tuple = (org-symbol depth comment) (case field (org-symbol (setf (nth 0 tuple) value)) (depth (setf (nth 1 tuple) value)) (comment (setf (nth 2 tuple) value)) (toplevel (setf (nth 3 tuple) value)) (t (error "Internal error in : unknown field.")) ) new-table )) (defun com-get-field (table vari field &key (signal-errorp t)) "Get vari.field. See also com-set-field. If signal-errorp = NIL it returns NIL if vari does not exist in table, If signal-errorp = T it signals an error if vari does not exist in table." (let* ((pair (assoc vari table)) (tuple (cdr pair)) ) (cond(pair (case field (org-symbol (nth 0 tuple)) (depth (nth 1 tuple)) (comment (nth 2 tuple)) (toplevel (nth 3 tuple)) (t (error "Internal error in : unknown field.")) )) (signal-errorp (error "Internal error in : unknown variable. ")) (t nil) ))) (defun com-get-fields (table vari) "Lookup vari in table. Return a tuple if it exists, nil otherwise." (cdr (assoc vari table)) ) ;;; Extract comments: ;;; ----------------- (defun replace-user-symbol (symbol-or-number table tag-p) "Generates a new symbol. Records the new symbol and its old counterpart in the table. Returns a list: (

) " (if (funcall tag-p symbol-or-number) ;; protect hn, ft etc.: (list symbol-or-number table) (let* ((str (if (numberp symbol-or-number) (stringcat "number_" (princ-to-string symbol-or-number)) (princ-to-string symbol-or-number)) ) (new-symbol (gentemp (stringcat str "_"))) ) (list new-symbol (com-set-field table new-symbol 'org-symbol symbol-or-number ))))) (defun replace-user-symbols (expr table tag-p) "Replaces all user symbols in expr by symbols generated by gentemp. table records the replacements. Returns a list: (

)" (cond ((com-cell-p expr) (let+ (((e1 t1) (replace-user-symbols (com-cell-lisp expr) table tag-p) )) (list (make-com-cell :lisp e1 :pre-txt (com-cell-pre-txt expr) :post-txt (com-cell-post-txt expr) ) t1 ))) ((atom expr) (replace-user-symbol expr table tag-p) ) ;; expr is a cons-cell: ((null (cdr expr)) ;; do not replace a trailing NIL: (let+ (((e1 t1) (replace-user-symbols (car expr) table tag-p))) (list (list e1) t1) )) (t (let*+ (((e1 t1) (replace-user-symbols (car expr) table tag-p)) ((e2 t2) (replace-user-symbols (cdr expr) t1 tag-p)) ) (list (cons e1 e2) t2) )))) (defun assoc-expr-with-comment (expr comment depth table tag-p toplevelp) "Associates comment with expr. This is done by finding the first symbol in expr and associating it with comment . The parameter toplevelp indicates a toplevel comment, depth is not used in this case. Returns an updated table." (cond ((null expr) nil ) ((com-cell-p expr) (assoc-expr-with-comment (com-cell-lisp expr) comment depth tag-p table toplevelp)) ((and (atom expr) (funcall tag-p expr) ) ;; protect tags like hn, ft etc.: nil ) ((and (atom expr) toplevelp) ;; it is a userdefined symbol: (com-set-field table expr 'toplevel comment) ) ((atom expr) ;; it is a userdefined symbol: (com-set-field table expr 'comment comment) (com-set-field table expr 'depth (min depth com-max-depth)) ) ;; it is a cons-cell: ((assoc-expr-with-comment (car expr) comment (1+ depth) table tag-p toplevelp)) (t (assoc-expr-with-comment (cdr expr) comment (1+ depth) table tag-p toplevelp)) )) (defun remove-com-cells (expr table tag-p) "Removes all com-cells from expr. Returns a list: (

) Where updated-table associates symbols with tuples. tuple = (

) ." (let*+ (((copy-of-expr table1) (replace-user-symbols expr table tag-p)) ((com-free-expr table2 ) (remove-com-cells-aux copy-of-expr table1 tag-p ))) (list com-free-expr table2) )) (defun remove-com-cells-aux (expr table tag-p) (cond ((consp expr) (let*+ (((e1 t1) (remove-com-cells-aux (car expr) table tag-p)) ((e2 t2) (remove-com-cells-aux (cdr expr) t1 tag-p)) ) (list (cons e1 e2) t2) )) ((not (com-cell-p expr)) (list expr table) ) ;; it is a com-cell: ((string= "" (stringcat (com-cell-pre-txt expr) (com-cell-post-txt expr))) ;; the comment is intern: (remove-com-cells-aux (com-cell-lisp expr) table tag-p) ) (t (let*+ ((comment (stringcat (com-cell-pre-txt expr) (com-cell-post-txt expr))) (e1 (com-cell-lisp expr)) (t1 (assoc-expr-with-comment e1 comment 0 table tag-p nil)) ) (remove-com-cells-aux e1 t1 tag-p) )))) (defun remove-comments-from-database (database-with-comments tag-p) "Returns a list (

) has no comment at all.

can be used to reinsert the comments (ref. insert-comments). = (

) records the first and the last comment of the database." (let (start-comment rest-db) (if (stringp (car database-with-comments)) (setq start-comment (car database-with-comments) rest-db (cdr database-with-comments) ) (setq start-comment "" rest-db database-with-comments )) (let*+ ((triple (remove-comments-from-database-aux rest-db nil tag-p)) ((db-wo-comments table end-comment) triple) ) (list db-wo-comments table (list start-comment end-comment)) ))) (defun remove-comments-from-database-aux (db-w-comment table tag-p) "Returns a triple: (

) " (cond ((null db-w-comment) (list nil table "") ) ;; it is a cons-cell: ((and (null (cdr db-w-comment)) (stringp (car db-w-comment))) ;; database ends with a comment: (list nil table (car db-w-comment)) ) ((stringp (car db-w-comment)) ;; comment between clauses: (let*+ (((d1 t1) (remove-com-cells (second db-w-comment) table tag-p)) (t2 (assoc-expr-with-comment d1 (car db-w-comment) 0 t1 tag-p t)) ((d3 t3 e3) (remove-comments-from-database-aux (cddr db-w-comment) t2 tag-p ))) (list (cons d1 d3) t3 e3) )) (t (let*+ (((d1 t1) (remove-com-cells (car db-w-comment) table tag-p)) ((d2 t2 e2) (remove-comments-from-database-aux (cdr db-w-comment) t1 tag-p) )) (list (cons d1 d2) t2 e2) )))) ;;; Insert comments: ;;; ---------------- (defun get-toplevel-comments (symbols table) "Returns a string with the toplevel comments of the symbols. Condition on entry: Every symbol has a toplevel comment." (if (null symbols) "" (stringcat (com-get-field table (car symbols) 'toplevel) (get-toplevel-comments (cdr symbols) table) ))) (defun re-assoc-comment (depth comment list-of-comments) (let ((cons-cell (nthcdr depth list-of-comments))) (setf (car cons-cell) (stringcat (car cons-cell) comment) ))) (defun insert-comments-into-expr (expr table) (insert-comments-into-expr-aux expr table nil) ) (defun insert-comments-into-expr-aux (expr table list-of-comments) (cond ((symbolp expr) (let*+ ((tuple (com-get-fields table expr)) ((org-symbol0 depth comment) tuple) (org-symbol (lisp-sym->pro-sym org-symbol0)) ) (cond ((null tuple) ;; expr is a new symbol expr ) ((string= "" comment) ;; no comment associated org-symbol ) ((= 0 depth) (make-com-cell :lisp org-symbol :post-txt comment )) (t ;; comment associated with x: (re-assoc-comment (1- depth) comment list-of-comments) org-symbol )))) ((consp expr) (let* ((ext-list-of-comments (cons "" list-of-comments)) (expr-with-comments (mapcar #'(lambda (x) (insert-comments-into-expr-aux x table ext-list-of-comments)) expr )) (top-comment (car ext-list-of-comments)) ) (if (string= "" top-comment) expr-with-comments (make-com-cell :lisp expr-with-comments :post-txt top-comment )))) (t expr ) )) (defun insert-comments-into-database (database table start-end-comments) "Returns a database with comments, printable by print-database-with-comments." (let+ (((start-comment end-comment) start-end-comments)) (remove "" (append (list start-comment) (insert-comments-into-database-aux database table) (list end-comment) ) :test #'equal ))) (defun insert-comments-into-database-aux (database table) (if (null database) nil (let* ((expr (car database)) (symbols-with-toplevel-comments (extract-atoms-by-predicate expr #'(lambda (x) (and (symbolp x) (let ((tuple (com-get-fields table x))) (and tuple (string/= "" (fourth tuple)) )))))) (toplevel-comments (if symbols-with-toplevel-comments (list (get-toplevel-comments symbols-with-toplevel-comments table )) nil ))) (append toplevel-comments (cons (pack-comments (insert-comments-into-expr expr table)) (insert-comments-into-database-aux (cdr database) table)))))) (defun lift-comments (expr) "Comments at the end of an expression are lifted to the surrounding expression." (if (and (com-cell-p expr) (string= "" (com-cell-post-txt expr) ) (consp (com-cell-lisp expr)) ) (let* ((expr-1 (mapcar #'lift-comments (com-cell-lisp expr))) (expr-but-last (butlast expr-1)) (expr-last (car (last expr-1))) ) (if (and (com-cell-p expr-last) (string/= "" (com-cell-post-txt expr-last)) ) ;; the last arg. of expr has a comment --> lift it: (let ((internal-comment-p (or (any-true-p expr-but-last #'com-cell-p) (com-cell-internal-p expr-last) ))) (make-com-cell :lisp (append expr-but-last (list (com-cell-lisp expr-last)) ) :pre-txt (com-cell-pre-txt expr-last) :post-txt (com-cell-post-txt expr-last) :internal-p internal-comment-p )) ;; the last arg. has no comment --> do not lift: (make-com-cell :lisp expr-1 :pre-txt (com-cell-pre-txt expr ) ; no post-txt :internal-p (com-cell-internal-p expr) ))) expr )) ;;; ------------------------------------------------------------------------- ;;; ;;; Main functions ;;; ;;; ------------------------------------------------------------------------- (defun echo-empty-lines (i-stream comment-lead-in) "Returns t iff at least one empty line read." (do ((non-white-char (first (read-until-non-white i-stream)) (first (read-until-non-white i-stream)) ) (empty-lines-p nil t) ) ((or (char= eof-char non-white-char) (char/= #\newline non-white-char) ) (when (and empty-lines-p (char/= comment-lead-in non-white-char)) (pro-newline-and-indent 1) ) empty-lines-p ) (read-char i-stream) (when empty-lines-p (pro-newline-and-indent 1)) )) (defun count-empty-lines (i-stream comment-lead-in) "Returns the number of empty lines in the i-stream. I.e. it returns the number of #\newlines read until a non-white-space or eof is reached." ;;(format t "~%(count-empty-lines): ~a ~@C" ;; "Next char to read:" ;; (peek-char nil i-stream nil eof-char) ) (declare (ignore comment-lead-in)) (do ((non-white-char (first (read-until-non-white i-stream)) (first (read-until-non-white i-stream)) ) (empty-lines-counter 0 (1+ empty-lines-counter)) ) ((or (char= eof-char non-white-char) (char/= #\newline non-white-char) ) ;;(when (and empty-lines-counter (char/= comment-lead-in non-white-char)) ;; (incf empty-lines-counter )) empty-lines-counter ) (read-char i-stream) )) (defun glue-comments (database) "database includes comments. On return all consecutive comments on toplevel are glued to a single string." (cond ((null database) nil ) ((or (stringp (car database)) (numberp (car database)) ) (glue-comments-aux database "") ) (t (cons (car database) (glue-comments (cdr database)) )))) (defun glue-comments-aux (database accu-string) (cond ((null database) (list accu-string) ) ((stringp (car database)) (glue-comments-aux (cdr database) (stringcat accu-string (car database))) ) ((numberp (car database)) (glue-comments-aux (cdr database) (stringcat accu-string ;; print-comment does not print the last newline: (string #\newline) (gen-n-newlines (car database))) )) (t (cons accu-string (glue-comments database) )))) (defun read-database-with-comments (input-stream input-style) "Reads a database-stream. Returns a list: Strings denote comments between clauses. Clauses may be encapsulated within com-cells. Input-style is one of {lisp, prolog, kif}." (let (*style* db) (case input-style (lisp (setq *style* 'lisp db (read-database-with-comments-lsyn input-stream *rfi-readtable* ))) (prolog (setq *style* 'prolog db (read-database-with-comments-psyn input-stream) )) #| (kif (setq *style* 'lisp db (read-database-with-comments-lsyn input-stream *kif-readtable* ))) |# (t (error "Internal error in read-database-with-comments.")) ) (glue-comments db) )) (defun read-database-with-comments-lsyn (lsyn-stream a-readtable) "See read-database-with-comments for documentation." (let* ((*readtable* (setup-comment-readtable a-readtable)) ) (do* ((empty-lines-counter (count-empty-lines lsyn-stream lsyn-comment-lead-in) (count-empty-lines lsyn-stream lsyn-comment-lead-in) ) (non-white-char (peek-char nil lsyn-stream nil eof-char) (peek-char nil lsyn-stream nil eof-char)) (type-of-comment 2 (if (zerop empty-lines-counter) 1 2)) (result) ) ((char= eof-char non-white-char) (reverse result) ) (unless (zerop empty-lines-counter) (setq result (cons empty-lines-counter result)) ) (if (char= lsyn-comment-lead-in non-white-char) ;; comment detected: (progn (read-char lsyn-stream) ; consume the com-lead-in ;; print-comment starts with a #\newline for type-2-comments (setq result (cons (first (read-comments lsyn-comment-lead-in type-of-comment lsyn-stream )) result ))) ;; clause detected: (progn (setq result (cons (hide-comments (read lsyn-stream)) result )) ;; eat the #\newline if the rest of the line are whitespace chars. (when (char= (first (read-until-non-white lsyn-stream)) #\newline ) (read-char lsyn-stream) ))) ;;(format t "~%~a ~@C" ;; "Next char to read:" ;; (peek-char nil lsyn-stream nil eof-char) ) ))) (defun read-database-with-comments-psyn (psyn-stream) "See read-database-with-comments for documentation." (catch :pro-read-error-tag (let ((*comment-style* t)) ; do not remove comments (read-database-with-comments-psyn-aux (gen-scanner psyn-stream))))) (defun read-database-with-comments-psyn-aux (scanner) "See read-database-with-comments for documentation." (cond ((funcall scanner 'comment-p) ;; comment detected: (cons (funcall scanner 'comment) (read-database-with-comments-psyn-aux scanner) )) ((funcall scanner 'str-of-newlines-p) (let ((l (length (funcall scanner 'str-of-newlines)))) (if (> l 1) ;; no comment but empty lines after the last clause: (cons (1- l) (read-database-with-comments-psyn-aux scanner) ) (read-database-with-comments-psyn-aux scanner) ))) ((eq 'empty (funcall scanner 'last-token-type)) nil ) (t ;; clause detected: (cons (hide-comments (parse-clause scanner)) (read-database-with-comments-psyn-aux scanner) )))) (defun print-database-with-comments (database output-stream comment-style) "Prints a database produced by read-database-with-comments" (let* ((*comment-style* comment-style) (*rfi-standard-output* output-stream) (comment-lead-in (if (eq *style* 'lisp) lsyn-comment-lead-in psyn-comment-lead-in )) ) (do ((cursor-col 1) (item (car database) (car rest-database)) (rest-database (cdr database) (cdr rest-database)) ) ((null item) t ) (cond ((numberp item) (dotimes (i item) (pro-newline-and-indent 1)) (setq cursor-col 1) ) ((stringp item) (print-comment item comment-lead-in cursor-col 1) ) (t (pro-newline-and-indent 1) (setq cursor-col (pp-clause item)) ))))) (defun generate-iso-prolog-text (database out-stream comment-style) "Prints database in a style readable by ISO-Prolog." (let*+ (((db-without-comments table start-end-comments) (remove-comments-from-database database #'rf-tag-p )) (*style* 'prolog) (*print-like-prolog* t) (db-flattened (rfp-db-2-pl-db (extrarg-database (passtup ;;pl-flatter/db (flatten-database db-without-comments) )) table )) (db-flattened-with-comments (insert-comments-into-database db-flattened table start-end-comments ))) (print-database-with-comments db-flattened-with-comments out-stream comment-style))) ;; --------------------------------------------------------------------------- ;; rfx2rfx - functions ;; --------------------------------------------------------------------------- (defun rf2rf (lsyn-in lsyn-out comment-style) "Pretty prints a file written in L-syntax including the comments." (let* ((*comment-style* comment-style) (*style* 'lisp) (*readtable* (setup-comment-readtable *rfi-readtable*)) (*rfi-standard-output* lsyn-out) ) (do* ((empty-lines-p (echo-empty-lines lsyn-in lsyn-comment-lead-in) (echo-empty-lines lsyn-in lsyn-comment-lead-in)) (cursor-col 1 (if empty-lines-p 1 cursor-col)) (non-white-char (peek-char nil lsyn-in nil eof-char) (peek-char nil lsyn-in nil eof-char)) (type-of-comment 2 (if empty-lines-p 2 1)) ) ((char= eof-char non-white-char) t) (if (char= lsyn-comment-lead-in non-white-char) ;; comment detected: (progn (read-char lsyn-in) ; consume the com-lead-in (print-comment (first (read-comments lsyn-comment-lead-in type-of-comment lsyn-in )) lsyn-comment-lead-in cursor-col 1 ) ; 1 = indent-col. (pro-newline-and-indent 1) ) ;; clause detected: (progn (setq cursor-col (pp-clause (hide-comments (read lsyn-in)))) ))))) (defun rf2rfp (lsyn-stream psyn-stream comment-style) ;; Transforms a file written in L-syntax to P-Syntax including the ;; comments. (let* ((*comment-style* comment-style) (*readtable* (setup-comment-readtable *rfi-readtable*)) (*rfi-standard-output* psyn-stream) ) (do* ((empty-lines-p (echo-empty-lines lsyn-stream lsyn-comment-lead-in) (echo-empty-lines lsyn-stream lsyn-comment-lead-in)) (cursor-col 1 (if empty-lines-p 1 cursor-col)) (non-white-char (peek-char nil lsyn-stream nil eof-char) (peek-char nil lsyn-stream nil eof-char)) (type-of-comment 2 (if empty-lines-p 2 1)) ) ((char= eof-char non-white-char) t) (if (char= lsyn-comment-lead-in non-white-char) ;; comment detected: (progn (read-char lsyn-stream) ; consume the com-lead-in ;; print-comment starts with a #\newline for type-2-comments (print-comment (first (read-comments lsyn-comment-lead-in type-of-comment lsyn-stream )) psyn-comment-lead-in cursor-col 1 ) ; 1 = indent-col. (pro-newline-and-indent 1) ) ;; clause detected: (progn (setq cursor-col (pro-print (hide-comments (read lsyn-stream)))) ))))) (defun rfp2rfp (psyn-in psyn-out comment-style) ;; Pretty print a file written in P-syntax including the comments. (let* ((*comment-style* comment-style) (*rfi-standard-output* psyn-out) scanner ) (catch :pro-read-error-tag (do* ((empty-lines-p (echo-empty-lines psyn-in psyn-comment-lead-in) (echo-empty-lines psyn-in psyn-comment-lead-in)) (cursor-col 1 (if empty-lines-p 1 cursor-col)) (non-white-char (peek-char nil psyn-in nil eof-char) (peek-char nil psyn-in nil eof-char)) (type-of-comment 2 (if empty-lines-p 2 1)) ) ((char= eof-char non-white-char) t) (if (char= psyn-comment-lead-in non-white-char) ;; comment detected: (progn (read-char psyn-in) ; consume the com-lead-in ;; print-comment starts with a #\newline for type-2-comments (print-comment (first (read-comments psyn-comment-lead-in type-of-comment psyn-in )) psyn-comment-lead-in cursor-col 1 ) ; 1 = indent-col. (pro-newline-and-indent 1) ) ;; clause detected: (progn (if scanner nil (setq scanner (gen-scanner psyn-in)) ) (setq cursor-col (pro-print (hide-comments (parse-clause scanner)))) ;(princ cursor-col) (if (funcall scanner 'comment-p) (progn (print-comment (funcall scanner 'comment) psyn-comment-lead-in cursor-col 1 ) (pro-newline-and-indent 1)) (progn (dotimes (i (length (funcall scanner 'str-of-newlines))) (pro-newline-and-indent 1) ) )))))))) (defun rfp2rf (psyn-stream lsyn-stream comment-style) ;; Transforms a file written in P-syntax to L-Syntax including the ;; comments. (let* ((*comment-style* comment-style) (*style* 'lisp) (*rfi-standard-output* lsyn-stream) scanner ) (catch :pro-read-error-tag (do* ((empty-lines-p (echo-empty-lines psyn-stream psyn-comment-lead-in) (echo-empty-lines psyn-stream psyn-comment-lead-in)) (cursor-col 1 (if empty-lines-p 1 cursor-col)) (non-white-char (peek-char nil psyn-stream nil eof-char) (peek-char nil psyn-stream nil eof-char)) (type-of-comment 2 (if empty-lines-p 2 1)) ) ((char= eof-char non-white-char) t) (if (char= psyn-comment-lead-in non-white-char) ;; comment detected: (progn (read-char psyn-stream) ; consume the com-lead-in (print-comment (first (read-comments psyn-comment-lead-in type-of-comment psyn-stream )) lsyn-comment-lead-in cursor-col 1 ) ; 1 = indent-col. (pro-newline-and-indent 1) ) ;; clause detected: (progn (if scanner nil (setq scanner (gen-scanner psyn-stream)) ) (setq cursor-col (pp-clause (hide-comments (parse-clause scanner)))) ;(princ cursor-col) (if (funcall scanner 'comment-p) (progn (print-comment (funcall scanner 'comment) lsyn-comment-lead-in cursor-col 1 ) (pro-newline-and-indent 1)) (progn (dotimes (i (length (funcall scanner 'str-of-newlines))) (pro-newline-and-indent 1) ) )))))))) (defun rf2pl (in-stream out-stream comment-style) "Transforms a stream written in Relfun's L-syntax to real Prolog-syntax" (generate-iso-prolog-text (read-database-with-comments in-stream 'lisp) out-stream comment-style )) (defun rfp2pl (in-stream out-stream comment-style) "Transforms a stream written in Relfun's P-syntax to real Prolog-syntax" (generate-iso-prolog-text (read-database-with-comments in-stream 'prolog) out-stream comment-style )) ;; --------------------------------------------------------------------------- ;; batches ;; --------------------------------------------------------------------------- (defun bal2bap (lsyn-stream psyn-stream comment-style) ;; Transforms a batch-file written in L-syntax to P-syntax. (let* ((*comment-style* comment-style) (*readtable* (setup-comment-readtable *rfi-readtable*)) (*rfi-standard-output* psyn-stream) goal-or-cmd first-symbol ) (do* ((empty-lines-p (echo-empty-lines lsyn-stream lsyn-comment-lead-in) (echo-empty-lines lsyn-stream lsyn-comment-lead-in)) (cursor-col 1 (if empty-lines-p 1 cursor-col)) (non-white-char (peek-char nil lsyn-stream nil eof-char) (peek-char nil lsyn-stream nil eof-char)) (type-of-comment 2 (if empty-lines-p 2 1)) ) ((char= eof-char non-white-char) t) (if (char= lsyn-comment-lead-in non-white-char) ;; comment detected: (progn (read-char lsyn-stream) ; consume the com-lead-in ;; print-comment starts with a #\newline for type-2-comments (print-comment (first (read-comments lsyn-comment-lead-in type-of-comment lsyn-stream )) psyn-comment-lead-in cursor-col 1 ) ; 1 = indent-col. (pro-newline-and-indent 1) ) ;; command or goal detected: (progn (setq goal-or-cmd (read-goal-or-cmd-from-lsyn-batch lsyn-stream) first-symbol (first goal-or-cmd) cursor-col (if (member first-symbol *rfi-commands*) (let ((first-symbol-as-string (stringcat (string-downcase (princ-to-string first-symbol) ) " " ))) (case first-symbol ((l listing) (cond ((null (cdr goal-or-cmd)) ;; listing without argument: (pro-print-string first-symbol-as-string 1) ) ((null (cddr goal-or-cmd)) ;; listing with symbol as argument: (pro-print (second goal-or-cmd) (pro-print-string first-symbol-as-string 1) )) (t ;; listing with head-pattern: (pro-print-head (second goal-or-cmd) (pro-print-string first-symbol-as-string 1) )))) (style (cond ((null (cdr goal-or-cmd)) ;; without argument: (pro-print-string first-symbol-as-string 1) ) ((eq 'lisp (second goal-or-cmd)) (pro-print-string "style prolog" 1) ) ((eq 'prolog (second goal-or-cmd)) (pro-print-string "style lisp" 1) ) (t ))) (sl (pro-print-string "sp" 1) ) (sp (pro-print-string "sl" 1) ) ((a0 az rx) (pro-print (second goal-or-cmd) (pro-print-string first-symbol-as-string 1)) ) (azhn (pro-print (cons 'hn (cdr goal-or-cmd)) (pro-print-string "az " 1)) ) (a0hn (pro-print (cons 'hn (cdr goal-or-cmd)) (pro-print-string "a0 " 1)) ) (azft (pro-print (cons 'ft (cdr goal-or-cmd)) (pro-print-string "az " 1)) ) (a0ft (pro-print (cons 'ft (cdr goal-or-cmd)) (pro-print-string "a0 " 1)) ) (rxft (pro-print (cons 'ft (cdr goal-or-cmd)) (pro-print-string "rx " 1)) ) (t ;; no special handling of the rfi-cmd: (dolist (element goal-or-cmd) (rf-princ-like-lisp element) (rf-princ-like-lisp " ") ) 50 ))) ;; it's a goal: (prog1 (pro-print-arg-list (construct-measure-tree-of-arg-list goal-or-cmd nil) 1 ; cursor col. 0 the-non-printing-char the-non-printing-char ))))))))) (defun bap2bal (psyn-stream lsyn-stream comment-style) ;; Transforms a batch-file written in P-syntax to L-syntax. (let* ((*comment-style* comment-style) (*rfi-standard-output* lsyn-stream) (*style* 'lisp) ; style when printing ) (do* ((empty-lines-p (echo-empty-lines psyn-stream psyn-comment-lead-in) (echo-empty-lines psyn-stream psyn-comment-lead-in)) (cursor-col 1 (if empty-lines-p 1 cursor-col)) (non-white-char (peek-char nil psyn-stream nil eof-char) (peek-char nil psyn-stream nil eof-char)) (type-of-comment 2 (if empty-lines-p 2 1)) ) ((char= eof-char non-white-char) t) (if (char= psyn-comment-lead-in non-white-char) ;; comment detected: (progn (print-comment (first (read-comments psyn-comment-lead-in type-of-comment psyn-stream )) lsyn-comment-lead-in cursor-col 1 ) ; 1 = indent-col. (pro-newline-and-indent 1) ) ;; command or goal detected: (setq cursor-col (let* ((goal-or-cmd (read-goal-or-cmd-from-psyn-batch psyn-stream)) (pair (pro-split-input goal-or-cmd)) (first-symbol (car pair)) (rest-of-line-as-string (cdr pair)) ) (if (member first-symbol *rfi-commands*) ;; it's a rfi-command: (let* ((first-symbol-as-string (stringcat (princ-to-string first-symbol) " " )) (start-column (length first-symbol-as-string)) (user-line-as-list (handle-rfi-cmd first-symbol rest-of-line-as-string goal-or-cmd ))) (rf-princ-like-lisp first-symbol-as-string) (case first-symbol ((a0 az rx) ;; print as clause: (pp-clause (second user-line-as-list) start-column ) ) ;; l and listing require no special printing: (t ;; rfi-cmd requires no special printing: (print-lsyn-enumeration (rest user-line-as-list) start-column )))) ;; it's a goal (at least 1 element): (print-lsyn-enumeration (pro-read-goal goal-or-cmd) 0) ))))))) (defun read-goal-or-cmd-from-lsyn-batch (the-input-stream) (do* ((goal-or-cmd (list (hide-comments (read the-input-stream))) (cons (hide-comments (read the-input-stream)) goal-or-cmd )) (non-white-char (car (read-until-non-white the-input-stream)) (car (read-until-non-white the-input-stream)) ) ) ((case non-white-char ((#\newline #\;) t) ; abort loop (t nil) ) ; continue (reverse goal-or-cmd) ) )) (defun read-goal-or-cmd-from-psyn-batch (the-input-stream) ;; Returns the complete input (may be multiple lines) as a string. (do* ((goal-or-cmd "" (stringcat goal-or-cmd (string ch))) (ch (peek-char nil the-input-stream) (peek-char nil the-input-stream)) (*style* 'prolog) ) (nil) (case ch (#\newline ;; end of input line but may be continued (when (pro-complete-cmd-p goal-or-cmd) (return goal-or-cmd) )) (#\% ;; comment at end of line: (if (pro-complete-cmd-p goal-or-cmd) (return goal-or-cmd) (let* ((str-stream (make-string-output-stream)) (echo-stream (make-echo-stream the-input-stream str-stream)) ) ;; value does not care, ;; but input chars are accumulated in str-stream: (read-comments psyn-comment-lead-in 1 ; type of comment echo-stream ) (setq goal-or-cmd (stringcat goal-or-cmd (get-output-stream-string str-stream) )) (close str-stream) ))) (t)) (setq ch (read-char the-input-stream)) )) (defun print-lsyn-enumeration (enum start-column) ;; Example: enum = (a b c) => a b c ;; Returns the cursor-col. ;; left-margin: start-column = 0. (pp-init start-column) (if (com-cell-p enum) ;; internal comment (never end-of-line comment): (pp-broken-list (com-cell-lisp enum) '|| '||) (pp-list enum '|| '||) ) (1+ pp-currentpos*) ) (defun translate-file (in-filename out-filename &key direction (comment-style *default-comment-style*)) "Translates a file from one syntax to the other including the comments. Filenames can be symbols or strings, if not supplied standard extensions are added. Empty or NULL out-filename means send to *standard-output*. Possible values for direction (always required) are: rf2rf, rf2rfp, rfp2rf, rfp2rfp, rf2pl, rfp2pl, bal2bap, bap2bal Example: (translate-file \"facfix.rf\" facfix :direction 'rf2rfp) This is equivalent to: (translate-file \"facfix.rf\" \"facfix.rfp\" :direction 'rf2rfp) " (let (error-p translator in-extension out-extension full-in-filename (full-out-filename (if (and (stringp out-filename) (string= "" out-filename) ) nil out-filename )) (comment-lead-in (if (eq 'prolog *style*) psyn-comment-lead-in lsyn-comment-lead-in )) ) (case direction (rf2rfp (setq in-extension ".rf" out-extension ".rfp" translator #'rf2rfp ) ) (rfp2rf (setq in-extension ".rfp" out-extension ".rf" translator #'rfp2rf )) (rf2rf (setq in-extension ".rf" out-extension ".rf" translator #'rf2rf )) (rfp2rfp (setq in-extension ".rfp" out-extension ".rfp" translator #'rfp2rfp )) (rf2pl (setq in-extension ".rf" out-extension ".pl" translator #'rf2pl )) (rfp2pl (setq in-extension ".rfp" out-extension ".pl" translator #'rfp2pl )) (bal2bap (setq in-extension ".bat" out-extension ".bat" translator #'bal2bap )) (bap2bal (setq in-extension ".bat" out-extension ".bat" translator #'bap2bal )) (t (setq error-p t in-extension "" out-extension "") )) (setq full-in-filename (rfi-extension in-filename in-extension)) (when full-out-filename (setq full-out-filename (rfi-extension out-filename out-extension)) ) (cond (error-p (rf-princ-like-lisp "Error: Illegal direction.") ) ((equal full-in-filename full-out-filename) (rf-princ-like-lisp "Error: Source = Destination") (setq error-p t) ) ((not (probe-file full-in-filename)) ;; the in-file must exist: (rf-princ-like-lisp (stringcat "Error: Source " full-in-filename " does not exist." )) (setq error-p t) ) ((and full-out-filename (probe-file full-out-filename)) ;; outfile exists: (if (rfi-yes-or-no-p "Destination already exists - overwrite? ") (delete-file full-out-filename) (setq error-p t) )) (t) ) (unless (and (numberp (first comment-style)) (member (second comment-style) '(raw comment-column comment-column-or-margin margin)) (member (third comment-style) '(break no-break) )) (setq error-p t) (rf-princ-like-lisp "Error: Illegal comment-style.") (rf-terpri) (rf-princ-like-lisp " Domain of the list comment-style is ") (rf-terpri) (rf-princ-like-lisp " ( ,") (rf-terpri) (rf-princ-like-lisp " {COMMENT-COLUMN, COMMENT-COLUMN-OR-MARGIN, MARGIN},") (rf-terpri) (rf-princ-like-lisp " {BREAK, NO-BREAK} )") ) (unless error-p (with-open-file (in-stream full-in-filename :direction :input) (rf-princ-like-lisp (format nil "~c Converting ~S " comment-lead-in full-in-filename) ) (if full-out-filename ;; send result to file: (with-open-file (out-stream full-out-filename :direction :output) (rf-princ-like-lisp (format nil "to ~S .." full-out-filename) ) (rf-terpri) (funcall translator in-stream out-stream comment-style) ) ;; send result to terminal: (progn (rf-princ-like-lisp "..") (rf-terpri) (funcall translator in-stream *rfi-standard-output* comment-style )) ))))) (pushnew :rf-comment *features*) ;;; ------------------------------------------------------------------------- ;;; ;;; End of module comment.lsp ;;; ;;; ------------------------------------------------------------------------- ;;;### eof ;;;### File "lisp2pro.lisp" ;;; Copyright Notice ;;; ;;; This software is distributed for non-profit and research purposes only. ;;; 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. ;;; ;;; Michael Herfert, Harold Boley (boley@informatik.uni-kl.de) ; ----------------------------------------------------------------------------- ; Module Lisp2Pro.Lsp: Transforms an expression given in the Lisp-like ; syntax into the Prolog-like syntax. ; ; ; 2/92: First Version ; 7/92: Fixed problem with "|" ; 9/92: Print of comments ; 2/93: miser-level, pro-print* ; 3/94: uc-tag, typ-tag, printing of infix-forms ; 7/94 Capability to produce ISO-Prolog code ; 2/97: newsyn for clauses via new type-of-clause's hn/ft-cutfact/rule ; 3/97: newsyn for is via simple ".=" substitution ; 11/97: corrected newsyn for printing correct iso-prolog-'is' in rfp2pl/rf2pl ; ; ; ; ; Exported Item: ; ; pro-print expr-or-clause-in-lisp-syntax [Function] ; ; Prints the argument in a pretty-print format in Prolog-like syntax. ; (defvar *miser-level* 2 "Parameter of P-syntax pretty printer. 0: Use many lines to print an expression. 1: Never break a line if it can contain the expression. 2: Insert spaces only between factors of the body. 3: Never insert spaces. (2) and (3) are prerelease versions. ") (defmacro compact-mode-p () '(> *miser-level* 0)) ;; Try at top level with miser-level 0 and 1: ;; [1, 2, 3, 4, [a, b, c, d, e, f, g, h, i], 5, 6, 7, 8] (defmacro print-one-space-or-not () (quote (if (or (<= *miser-level* 1) (and (= 2 *miser-level*) body-p) ) (pro-print-char #\space new-x-cursor) new-x-cursor ))) (defun inst-tup-t (x) (and (inst-t x) (tup-t (second x)) )) (defun inst-vari-t (x) (and (inst-t x) (vari-t (second x)) )) (defun variable-binding-t (x) (and (consp x) (= 3 (length x)) ;(vari-t (first x)) (eq '= (second x)) )) (defun cut-sym-t (x) (and (not *print-like-prolog*) ; ignore cut while generating (eq '! x) )) ; code for ISO-Prolog ;; The following constants are parameters of the pretty printer. ;; They can be changed here without side effects: ;; Small number ==> use many lines when printing: (defconstant max-len-of-a-simple-arg 7) ;; Small number ==> use many lines when printing: (defconstant max-args-per-line 3) (defun internal-error (&rest msgs) (mapcar #'rf-print msgs) (error "Internal-Error.") ) ;; The type pro-expr describes the Prolog-like representation of a RelFun- ;; expression. ;; The field len describes the space to print the whole expression ;; including commas, spaces and parentheses resp. brackets. ;; The contents of value depends on the value of type: ;; type = atomic (that means constant or variable) ;; value: the string-form of the atom. ;; type = argument-list ;; value: a list of triples: (

) ;; (seldom used) is e.g. #\| ;; is a pro-expr describing the argument ;; (often used) is e.g. #\, ;; type = round-application (e.g. f(x, y)) ;; value: a list. First element: the functor, ;; Second element: the argument-list. ;; type = sqr-application (e.g. g[a,b]) ;; value: a list. First element: the functor or nil if it is a tupel. ;; Second element: the argument-list. ;; type = infix (e.g. X is 5) ;; value: a list. 1st element: left side ;; 2nd connector ;; 3rd right-side ;; type in {hn-fact, hn-rule, ft-fact, ft-rule, uc-clause, file-clause}: ;; value: a list: 1st element: head ;; 2nd connector (e.g. " :- ") ;; 3rd body (body is of type arg-list) (defstruct pro-expr type ; dom(type) = {round-application, sqr-application, ; argument-list, arg-list-tail, is, ; variable-binding, atomic} len ; dom(len) = integer value ; dom(value) = STRING u pro-expr. internal-p ; <==> comment inside value (pre-txt "") ; dom = STRING (post-txt "") ; dom = STRING ;; If comment begins with a #\newline then it's a begin-of-line-comment, ;; otherwise the first substring (upto the first #\newline) is a ;; end-of-line-comment. ;; If comment is not the empty string it is terminated by #\newline. ;; comment is printed after value. ) (defun newline-indent (indent) (rf-terpri) (dotimes (i indent) (rf-princ-like-lisp " ") )) (defun pps (s &optional (indent 0) &key rem) ;; pretty-print-structure useful for debugging. (if rem (progn (rf-terpri) (rf-princ-like-lisp rem) (rf-terpri))) (cond ((pro-expr-p s) (rf-princ-like-lisp " <*pro-expr*>") (newline-indent indent) (rf-princ-like-lisp "Type: ") (rf-princ-like-lisp (pro-expr-type s)) (newline-indent indent) (rf-princ-like-lisp "Len: ") (rf-princ-like-lisp (pro-expr-len s)) (newline-indent indent) (rf-princ-like-lisp "Val: ") (pps (pro-expr-value s) (+ indent 6)) ) ((consp s) (rf-princ-like-lisp "[") (mapcar #'(lambda (x) (newline-indent (1+ indent)) (pps x (1+ indent)) ) s) (newline-indent indent) (rf-princ-like-lisp "]")) (t (rf-princ-like-lisp s) )) s) (defun construct-measure-tree (expr must-be-sqr-p &aux pair triple) ;; Returns a value of type pro-expr. ;; The parameter must-be-sqr-p signals that all round applications ;; have to be transformed to sqr-applications, because the call came ;; from inside a sqr argument list. (cond ((com-cell-p expr) (construct-measure-tree-of-com-cell expr must-be-sqr-p) ) ((stringp expr) (make-pro-expr :type 'atomic :len (flatsize expr) :value (prin1-to-string expr) )) ((eq 'id expr) (make-pro-expr :type 'atomic :len 1 :value "_" )) ;;((and (characterp expr) (char= expr the-non-printing-char)) ;; used for empty lines within an expression ;;(make-pro-expr :type 'atomic ;; :len 0 ;; :value "" )) ((atom expr) (make-pro-expr :type 'atomic :len (flatc expr) ;; :value (string-downcase (prin1-to-string expr)) )) ;; |1.2.3| ==> 1.2.3 :value (string-downcase (princ-to-string expr)) )) ((vari-t expr) ;; expr = (VARI symbol) (let ((name-conc-level (pro-get-variable expr))) (make-pro-expr :type 'atomic :len (length name-conc-level) :value name-conc-level ))) ((eq 'typ (first expr)) ;; expr = (TYP vari-or-symbol) (let ((vari-or-symbol (construct-measure-tree (second expr) nil))) (make-pro-expr :type 'atomic :len (1+ (pro-expr-len vari-or-symbol)) :value (stringcat "$" (pro-expr-value vari-or-symbol)) ))) ((variable-binding-t expr) ;; expr = (variable = binding-value) ;; If the interpreter is active, then variable is a symbol with ;; leading "_" (e.g. _xyz). ;; If the emulator is active then, variable is a taged list ;; (e.g. (vari x)) (let ((var-as-str (if (atom (first expr)) (lisp-var-sym->pro-var-sym (first expr)) (pro-get-variable (car expr)) ))) (setq triple (list (make-pro-expr :type 'atomic :len (length var-as-str) :value var-as-str ) "=" (construct-measure-tree (third expr) must-be-sqr-p )))) (make-pro-expr :type 'infix :len (+ 3 ; 3 = length(" = ") (pro-expr-len (first triple)) (pro-expr-len (third triple)) ) :value triple )) ((and *print-like-prolog* nil (eq '= (car expr)) ) ;; this is not realy necessary to generate ISO-PROLOG-Code, ;; but it looks better if '=' is printed as infix. ;; (= variable value) ==> (variable = value) (construct-measure-tree (list (second expr) '= (third expr)) must-be-sqr-p )) ((pro-clause-t expr) (construct-measure-tree-of-clause expr must-be-sqr-p) ) ((pro-is-t expr) ;; expr = (IS left right) ;; impl. INST on the left side (setq triple (list (construct-measure-tree (second expr) t ) ;left ".=" ;HB; "is" (construct-measure-tree (third expr) nil ) )) ;right (make-pro-expr :type 'infix :len (+ 4 ; 4 = length(" is ") (pro-expr-len (first triple)) (pro-expr-len (third triple)) ) :value triple )) ((typed-expr-t expr) (setq triple (list (construct-measure-tree (typed-expr-term expr) nil) ":" (construct-measure-tree (typed-expr-type expr) nil))) (make-pro-expr :type 'infix :len (+ 3 ; 1 = length(" : ") (pro-expr-len (first triple)) (pro-expr-len (third triple)) ) :value triple )) ((and must-be-sqr-p (pro-tup-t expr)) ;; expr = (tup arg-1 .. arg-n) ;; inst outside --> suppress the tup-constructor (setq pair (list ; constructor & argument-list nil (construct-measure-tree-of-arg-list (cdr expr) t ) )) (make-pro-expr :type 'sqr-application :len (pro-expr-len (second pair)) :value pair )) (must-be-sqr-p ;; expr = (constructor arg-1 .. arg-n) ;; inst outside --> handle inst like any other constructor (setq pair (list ; constructor & argument-list (construct-measure-tree (first expr) t) (construct-measure-tree-of-arg-list (cdr expr) t) )) (make-pro-expr ;;:type 'sqr-application :type (if *print-like-prolog* 'round-application 'sqr-application) :len (+ (pro-expr-len (first pair)) (pro-expr-len (second pair)) ) :value pair )) ;; there was no inst outside: ;; By the following case (inst (vari x)) is printed as X if there ;; was no inst outside. ;; Remove this sexpression and (inst (vari x)) is printed as inst(X). ((inst-vari-t expr) (construct-measure-tree (second expr) nil) ) ((and (inst-t expr) (not (vari-t (second expr)))) ;; expr = (INST (constructor arg-1 .. arg-n)) (construct-measure-tree (second expr) t) ) (t ;; expr = (functor arg-1 .. arg-n) (setq pair (list (construct-measure-tree (first expr) nil) (construct-measure-tree-of-arg-list (cdr expr) nil))) (make-pro-expr :type 'round-application :len (+ (pro-expr-len (first pair)) (pro-expr-len (second pair)) ) :value pair )))) (defun construct-measure-tree-of-arg-list (arg-list must-be-sqr-p &key foot-p) ;;; Not only used for argument list but also used for body. ;; Returns a value of type pro-expr. ;; The len-field contains the whole length included parentheses ;; (or brackets), commas and spaces. ;; The type-field is of type ARGUMENT-LIST. ;; The value-field is a list of elements. ;; Each element is a triple: ;; (

) (do* ((rest-args arg-list (rest rest-args)) (arg (first rest-args) (first rest-args)) (next-arg (second rest-args) (second rest-args)) (ignore-next-arg-p nil) (total-length 2) ; len("()") (triple nil (list pre-sep tree post-sep)) (pro-arg-list nil (if tree (cons triple pro-arg-list) pro-arg-list)) (internal-comment-p nil (or internal-comment-p (and tree (pro-expr-internal-p tree)) (and tree (string/= "" (pro-expr-pre-txt tree))) (and tree (string/= "" (pro-expr-post-txt tree))) )) (pre-sep) (tree) (post-sep) ) ((null rest-args) ;; end of do-loop: (make-pro-expr :type 'argument-list :value (reverse pro-arg-list) :internal-p internal-comment-p :len total-length )) (if ignore-next-arg-p (setq ignore-next-arg-p nil tree nil ) (cond ((cut-sym-t arg) ;; cut is the first el. in arg-list: (cond ((null (cdr rest-args)) ;; arg-list = (!) (setq tree (construct-measure-tree '! must-be-sqr-p) post-sep the-non-printing-char )) ((and foot-p (null (cddr rest-args)) ) ;; arg-list = (! ) (setq tree (construct-measure-tree next-arg must-be-sqr-p ) pre-sep "!& " post-sep the-non-printing-char ignore-next-arg-p t )) ((null (cddr rest-args)) ;; arg-list = (! ) (setq tree (construct-measure-tree next-arg must-be-sqr-p) pre-sep "! " post-sep the-non-printing-char ignore-next-arg-p t )) (t ;; arg-list = (! .. ) (setq tree (construct-measure-tree next-arg must-be-sqr-p) pre-sep "! " post-sep (if (and foot-p ; M.S. 11/1993 (= (length rest-args) 3)) " &" #\,) ignore-next-arg-p t ))) (if (stringp post-sep) ; M.S. (incf total-length (1+ (length post-sep))) (when (char/= the-non-printing-char post-sep) (incf total-length 2))) ; 2=len(", ") (automatic space) (when pre-sep (incf total-length (length pre-sep)) ) (incf total-length (pro-expr-len tree)) ) ((eq '|\|| arg) ;; arg-list = (\| ) (setq tree (construct-measure-tree next-arg must-be-sqr-p) pre-sep #\| post-sep the-non-printing-char ignore-next-arg-p t) (incf total-length (+ 2 (pro-expr-len tree))) ; 2=len("| ") ) (t (setq pre-sep nil) (setq tree (construct-measure-tree arg must-be-sqr-p) ) (incf total-length (pro-expr-len tree)) (cond ((cut-sym-t next-arg) (if (null (cddr rest-args)) ;; cut at the end: (setq post-sep " !" ; 2=len(" !") total-length (+ total-length 2) ) ;; cut not at the end: ;; rest-args = ( ! ..) (if (and foot-p (null (cdddr rest-args))) ;; rest-args = ( ! ) (setq post-sep " !&" ; 4=len(" !& ") total-length (+ total-length 4) ) ;; no foot after cut: (setq post-sep " !" ; =len(" ! ") total-length (+ total-length 3) ))) (setq ignore-next-arg-p t) ) ((eq '|\|| next-arg) ;; arg-list = ( .. \| ) (incf total-length 3) ; 3 = len(" | ") ;; in the second case the length is not correct: (!!!) (setq post-sep (if (<= *miser-level* 1) " |" "|")) (setq ignore-next-arg-p t) ) ((null (rest rest-args)) ;; last element: (setq post-sep the-non-printing-char) ) ((or (and foot-p (null (cddr rest-args))) (and foot-p (null (cdddr rest-args)) (cut-sym-t (caddr rest-args)) )) ;; two versions of footed rule: ;; rest-args = ( ) ;; or rest-args = ( !) (incf total-length 3) ; 3=len(" & ") (if (= 3 *miser-level*) (setq post-sep " & ") ; prerelease (setq post-sep " &") )) (t (incf total-length 2) ; 2 = len(", ") (setq post-sep #\,) )) ))))) (defun construct-measure-tree-of-head (head) (cond ((com-cell-p head) ;; the head has a comment: (let ((pro-head (construct-measure-tree-of-head (com-cell-lisp head)))) (setf (pro-expr-pre-txt pro-head) (com-cell-pre-txt head) (pro-expr-post-txt pro-head) (com-cell-post-txt head) ) pro-head )) ((consp head) ;; head = (functor arg-1 arg-2 .. ) (let ((pair (list ;; functor & argument-list (construct-measure-tree (first head) t) (construct-measure-tree-of-arg-list (cdr head) t) ))) (make-pro-expr :type 'round-application :len (+ (pro-expr-len (first pair)) (pro-expr-len (second pair)) ) :value pair ))) (t ;; head = ATOM (construct-measure-tree head nil) ))) (defun construct-measure-tree-of-clause (expr must-be-sqr-p) (declare (ignore must-be-sqr-p)) (let* ((type-of-clause (cond ((uc-t expr) 'uc-clause) ((mod-sub-module-t expr) 'file-clause) ((type-tag-eq expr 'hn) ;; hornish-clause: (cond ((= 2 (length expr)) 'hn-fact) ; (HN ) ((cut-sym-t (third expr)) (if (= 3 (length expr)) 'hn-cutfact ; (HN !) own neck 'hn-cutrule));(HN ! .. ) own neck (t 'hn-rule ))) ; (HN .. ) ;; footed-clause: ((type-tag-eq expr 'ft) (cond ((or (= 3 (length expr)) (and (= 4 (length expr)) (cut-sym-t (fourth expr)) )) 'ft-fact) ; (FT [!]) ((cut-sym-t (third expr)) (if (= 4 (length expr)) 'ft-cutfact ; (FT ! ) own neck 'ft-cutrule));(FT ! .. ) own neck (t 'ft-rule ))) ; (FT .. ) (t (error ": unknown tag.")) )) (head (construct-measure-tree-of-head (second expr))) (connector (case type-of-clause (hn-fact "") ; shortens " :-" (hn-cutfact "!") ; shortens " !-" (hn-rule " :- ") ((hn-cutrule ft-cutrule) " !- ") ; shortens " :- ! " ;; (ft-fact " :- & ") (ft-fact " :& ") ; shortens " :- & " (ft-cutfact " !& ") ; shortens " :& ! " (ft-rule " :- " ) ;; (uc-clause " :-# ") (uc-clause " :# ") ; newsyn (file-clause "") (t (error "Internal error: " )))) (body (construct-measure-tree-of-arg-list (if (or (eq 'hn-cutfact ;There's type-of-clause) ; a (eq 'hn-cutrule ;cut type-of-clause) ;in (eq 'ft-cutfact ;connector type-of-clause);(neck) (eq 'ft-cutrule type-of-clause)) ;thus (cdddr expr) ;here without cut (cddr expr)) nil ; must-be-sqr :foot-p (or (eq 'ft-rule type-of-clause) (eq 'ft-cutrule type-of-clause)) )) ) (decf (pro-expr-len body) 1) ; -1 = len(".") - len("()") (make-pro-expr :type type-of-clause :value (list head connector body) :internal-p (or (pro-expr-internal-p head) (pro-expr-internal-p body) ) :len (+ (pro-expr-len head) (pro-expr-len body) (length connector) )))) (defun construct-measure-tree-of-com-cell (expr must-be-sqr-p) ;; expr is a com-cell. (let ((tree (construct-measure-tree (com-cell-lisp expr) must-be-sqr-p ))) (setf (pro-expr-pre-txt tree) (com-cell-pre-txt expr) (pro-expr-post-txt tree) (com-cell-post-txt expr) (pro-expr-internal-p tree) (com-cell-internal-p expr) ) tree )) (defun pro-print (expr &optional (x-cursor 1)) ; Prints expr in the Prolog-style syntax. ; Starts at x-cursor. ; Returns no value (pro-print-tree (construct-measure-tree expr nil) x-cursor)) (defun pro-print* (expr x-cursor left-margin min-rest-space &optional continuation-indicator) ;; Prints expr in the Prolog-style syntax. ;; Assumes that cursor is in column x-cursor. ;; If expr does not fit on line and rest space is less than ;; min-rest-space then it begins a newline in column left-margin. ;; The continuation-indicator is printed at cursor-position if ;; expr starts at a new line. ;; Returns no value (let ((tree (construct-measure-tree expr nil)) (rest-col (- *rf-print-width* x-cursor)) (start-col x-cursor) ) (when (and (< rest-col min-rest-space) (> (pro-expr-len tree) rest-col) ) (when continuation-indicator (rf-princ-like-lisp continuation-indicator)) (setq start-col (pro-newline-and-indent left-margin)) ) (pro-print-tree tree start-col) )) ;; All functions named pro-print-... return the position of the ;; cursor after printing the expression. (defun pro-print-clause (expr x-cursor) ;; Printing of a clause: ;; 1.: .. . ;; 2.: ;; _________ .. . (_ means space) ;; 3.: ;; ____ .. . (let* ((value (pro-expr-value expr)) (head (first value)) (connector (second value)) (body (third value)) (comment-after-clause "") (cursor-pos-after-dot 0) ) (setq cursor-pos-after-dot (pro-print-char #\. (if (and (space-enough-p (pro-expr-len expr) x-cursor) (not (pro-expr-internal-p expr)) ) ;; fits in one line: (pro-print-arg-list body (pro-print-string connector (pro-print-tree head x-cursor :try-single-line-p t)) 0 the-non-printing-char the-non-printing-char :try-single-line-p t :body-p t ) ;; not on a single line: (let (new-cursor) (cond ((string= "" connector) ;; hn-fact ==> no connector (when (string/= (pro-expr-post-txt head) "") (setq comment-after-clause (pro-expr-post-txt head)) (setf (pro-expr-post-txt head) "")) (setq new-cursor (pro-print-tree head x-cursor :try-single-line-p t) )) ((space-enough-p head x-cursor (length connector)) ;; print as: (pro-print-tree head x-cursor :try-single-line-p t :post-script connector ) (setq new-cursor (pro-newline-and-indent (+ 9 x-cursor)))) (t ;; print as: ;; ____ .. (pro-print-tree head x-cursor :try-single-line-p t) (setq new-cursor (pro-print-string connector (pro-newline-and-indent (+ x-cursor 4)) )))) (pro-print-arg-list body new-cursor 0 ; don't go left the-non-printing-char the-non-printing-char :try-single-line-p t :body-p t ))))) (if (string= "" comment-after-clause) cursor-pos-after-dot (print-comment comment-after-clause (if (eq *style* 'prolog) psyn-comment-lead-in lsyn-comment-lead-in ) cursor-pos-after-dot 0 )))) (defun pro-print-head (head &optional (x-cursor 1)) (pro-print-tree (construct-measure-tree-of-head head) x-cursor) ) (defun pro-print-tree (tree x-cursor &key post-script try-single-line-p) ;; post-script (e.g. #\,) is printed after tree but before ;; a possibly existing comment. (unless (string= "" (pro-expr-pre-txt tree)) ;; print a leading comment (always type 2): (print-comment-type-2 (pro-expr-pre-txt tree) (if (char= #\newline (char (pro-expr-pre-txt tree) 0)) 1 0) psyn-comment-lead-in x-cursor ) (pro-newline-and-indent x-cursor) ) (let ((new-x-cursor (case (pro-expr-type tree) (atomic (pro-print-atom tree x-cursor) ) ((round-application sqr-application) (pro-print-application tree x-cursor :try-single-line-p (or (compact-mode-p) try-single-line-p) )) (infix (pro-print-infix tree x-cursor) ) ((hn-fact hn-rule hn-cutfact hn-cutrule ft-fact ft-rule ft-cutfact ft-cutrule uc-clause file-clause) (pro-print-clause tree x-cursor) ) (t (internal-error "Unknown tree-type in " (pro-expr-type tree) ))))) (when post-script (setq new-x-cursor (pro-print-txt post-script new-x-cursor)) ) (if (string= (pro-expr-post-txt tree) "") ;; no comment: new-x-cursor ;; print the comment: (print-comment (pro-expr-post-txt tree) psyn-comment-lead-in new-x-cursor x-cursor )))) (defun pro-print-atom (tree x-cursor) (if (space-enough-p tree x-cursor) (progn (rf-princ-like-lisp (pro-expr-value tree)) (+ x-cursor (pro-expr-len tree) )) (progn (rf-terpri) (rf-princ-like-lisp (pro-expr-value tree)) (pro-expr-len tree) ))) (defun pro-print-application (tree x-cursor &key try-single-line-p) ; type = round-application or sqr-application ; value = (functor arg-list) (let ((functor (first (pro-expr-value tree))) (arg-list (second (pro-expr-value tree))) (x x-cursor) (xx nil) (open-char nil) (close-char nil) ) (case (pro-expr-type tree) (round-application (setq open-char round-left) (setq close-char round-right) ) (sqr-application (setq open-char sqr-left) (setq close-char sqr-right) ) (t (error "in pro-print-application.")) ) (if functor ; it's not a list: (progn (if (space-enough-p functor x) ; never break a functor (setq x x-cursor) (setq x (pro-newline-and-indent 1)) ) (setq xx (pro-print-tree functor x :try-single-line-p (or (compact-mode-p) try-single-line-p ))) (when (string/= "" (pro-expr-post-txt functor)) ;; functor has a comment ==> args require a fresh line: (setq xx (pro-newline-and-indent (+ x 2)))) ) ; it's a list: (setq xx x) ) (pro-print-arg-list arg-list xx (+ x 2) open-char close-char :try-single-line-p (or try-single-line-p (compact-mode-p) )))) (defun pro-print-arg-list (arg-list x-cursor x-cursor-left open-char close-char &key try-single-line-p body-p) (let* ((elements (pro-expr-value arg-list)) (arg-list-info (get-arg-list-info elements)) (nr-of-el (first arg-list-info)) (max-len (second arg-list-info)) (simple-args-p (third arg-list-info)) (internal-comment-p (pro-expr-internal-p arg-list)) ) (cond ((and (or (<= nr-of-el max-args-per-line) simple-args-p try-single-line-p ) (space-enough-p (pro-expr-len arg-list) x-cursor) (not internal-comment-p) ) ;; functor(arg-1, arg2) (pro-print-char close-char (pro-print-arg-list-elements elements (pro-print-char open-char x-cursor) nil ; no extra-lines :try-single-line-p (or (compact-mode-p) try-single-line-p) :body-p body-p ))) ((or (space-enough-p max-len x-cursor 2) ; 2 = length(sqr-left",") (<= x-cursor x-cursor-left) try-single-line-p ) ;; functor( arg-1, ;; arg-2 ) (pro-print-char close-char (pro-print-arg-list-elements elements (pro-print-char open-char x-cursor) t ; print on separated lines :try-single-line-p (compact-mode-p) ; (miser) ))) (t ;; functor( ;; arg-1, ;; arg-2) (pro-print-char open-char x-cursor) (pro-print-char close-char (pro-print-arg-list-elements elements (pro-newline-and-indent x-cursor-left) t ; print on separated lines :try-single-line-p (compact-mode-p) ; (miser) )))))) (defun pro-print-arg-list-elements (elements x-cursor extra-lines-p &key try-single-line-p body-p) ;; each element is a triple: ( ) ;; is usualy not used (that means NIL) ;; is usualy #\, ;; it is the-non-printing-char for the last element. ;; body-p <==> it's the body of a clause (let ((new-x-cursor x-cursor) last-element-has-comment-p ) (mapl #'(lambda (rest-elements &aux (triple (car rest-elements))) (unless (null (first triple)) (setq new-x-cursor (pro-print-txt (first triple) new-x-cursor) )) (setq new-x-cursor (pro-print-tree (second triple) new-x-cursor :post-script (third triple) :try-single-line-p (or (compact-mode-p) try-single-line-p) )) (cond ((null (rest rest-elements)) ;; all elements printed ==> no space behind post-sep: (setq last-element-has-comment-p (string/= "" (pro-expr-post-txt (second triple))))) (t (setq new-x-cursor (if extra-lines-p (pro-newline-and-indent x-cursor) ;;(pro-print-char #\space new-x-cursor) (print-one-space-or-not) ))))) elements ) (if last-element-has-comment-p ;; last item was a comment ==> closing-char requires a fresh line: (pro-newline-and-indent x-cursor) new-x-cursor ))) (defun pro-print-infix (tree x-cursor) ;; type = infix ;; value = (left-side connector right-side) (let*+ ((x x-cursor) ((left-side connector right-side) (pro-expr-value tree)) (space-or-no-space (if (or (zerop *miser-level*) (string= ".=" connector) ;HB; .=+(3,3) not ; currently parsed either, so pp .= +(3,3) (alpha-char-p (character (elt connector 0) ))) " " "" )) ) (if (and *print-like-prolog* (string= ".=" connector)) (setf connector "is")) ; MP 27.11.97 for correct prolog output (setq x (pro-print-tree left-side x)) (if (comment-p left-side) ;; last item was a comment, print as: ;; ;; is (pro-print-tree right-side (pro-print-string (stringcat connector " ") x (pro-newline-and-indent x-cursor) )) (pro-print-tree right-side (pro-print-string (stringcat space-or-no-space connector space-or-no-space ) x x-cursor ))))) (defun pro-print-txt (char-or-string x-cursor) (if (characterp char-or-string) (pro-print-char char-or-string x-cursor) (pro-print-string char-or-string x-cursor) )) (defun pro-print-char (char x-cursor) (if (char= char the-non-printing-char) x-cursor (case char ((#\. #\, #\space) (rf-princ-like-lisp char) (1+ x-cursor) ) (t (if (space-enough-p 1 x-cursor) (progn (rf-princ-like-lisp char) (1+ x-cursor) ) (progn (pro-newline-and-indent 1) (rf-princ-like-lisp char) 2 )))))) ; 2 = Cursor column (defun pro-print-string (str x-cursor &optional (x-cursor-left 1)) ; Tries to print str on the current line. ; If not possible print on the next line at column x-cursor-left. (let ((str-wo-blank "")) (cond ((space-enough-p (length str) x-cursor) ; fits on line (rf-princ-like-lisp str) (+ x-cursor (length str) )) ((space-enough-p (length str) x-cursor-left) ; next line with indentation (pro-newline-and-indent x-cursor-left) (if (char= #\Space (char str 0)) (setq str-wo-blank (subseq str 1)) (setq str-wo-blank str) ) (rf-princ-like-lisp str-wo-blank) (+ x-cursor-left (length str-wo-blank) )) (t ; next line without indentation (pro-newline-and-indent 1) (if (char= #\Space (char str 0)) (setq str-wo-blank (subseq str 1)) (setq str-wo-blank str) ) (rf-princ-like-lisp str-wo-blank) (+ x-cursor-left (length str-wo-blank) ))))) (defun pro-newline-and-indent (x) (rf-terpri) (dotimes (i (1- x) x) (rf-princ-like-lisp " ")) ) (defun space-enough-p (tree-or-number x-cursor &optional (extra-space 0)) ; Note: the last column is reserved for special characters, which ; never should be printed at the begin of a line (e.g comma, ; point). (>= (- *rf-print-width* x-cursor extra-space) (if (pro-expr-p tree-or-number) (pro-expr-len tree-or-number) tree-or-number ))) (defun pro-get-variable (var) ; var = (VARI name level) ; where the level-field is optional. ; Example: var = (VARI time 127) ==> "Time:127" (let ((level (level-of var)) (name (string-upcase (string-downcase (princ-to-string (second var)) ) :start 0 :end 1 ))) (if (not (null level)) (setq name (stringcat name "*" (princ-to-string level))) ) (if (digit-char-p (character (subseq name 0 1))) (stringcat "_" name) name ))) (defun lisp-var-sym->pro-var-sym (lisp-var-sym) ; Example: input: _xyz ; output: Xyz (let ((pro-name (nstring-upcase (nstring-downcase (subseq (princ-to-string lisp-var-sym) 1)) :start 0 :end 1 ))) (if (digit-char-p (character (subseq pro-name 0 1))) (stringcat "_" pro-name) pro-name ))) (defun lisp-sym->pro-sym (symbol-or-string) "Replaces dashes by underscores in symbols. E.g. expr-type ==> expr_type Used to generate ISO-Prolog code." (if (symbolp symbol-or-string) (let* ((old-str (princ-to-string symbol-or-string)) (new-str (substitute #\_ #\- old-str :test #'char=)) ) (when (or (position #\? new-str :test #'char=) (position #\+ new-str :test #'char=) (position #\* new-str :test #'char=) (position #\/ new-str :test #'char=) ) (setq new-str (stringcat "'" new-str "'")) ) (intern new-str) ) symbol-or-string )) (defun get-arg-list-info (list-of-triples) ;; Returns a list. 1.: No. of elements ;; 2.: Length of biggest element. ;; 3.: simple-arg-p (do* ((n 0 (1+ n)) (maxi 0 (max maxi (pro-expr-len element) )) (simple-arg-p t (and simple-arg-p (or (eq 'atomic (pro-expr-type element) ) (<= (pro-expr-len element) max-len-of-a-simple-arg)))) (l list-of-triples (cdr l)) (triple (car l) (car l)) (element (second triple) (second triple) ) ) ((null l) (list n maxi simple-arg-p) ))) (defun type-tag-eq (expr tag-of-car) ;; <==> (car expr) is tag-of-car ;; Works with com-cells too. (cond ((com-cell-p expr) (type-tag-eq (com-cell-lisp expr) tag-of-car) ) ((consp expr) (eq (car expr) tag-of-car) ) (t nil ))) (defun pro-is-t (expr) ;; <==> IS is the car of expr. ;; Works with com-cells too. (type-tag-eq expr 'is) ) (defun pro-tup-t (expr) ;; <==> TUP is the car of expr. ;; Works with com-cells too. (type-tag-eq expr 'tup) ) (defun pro-clause-t (expr) ;; <==> HN or FT is the car of expr. ;; Works with com-cells too. (or (type-tag-eq expr 'hn) (type-tag-eq expr 'ft) (uc-t expr) (mod-sub-module-t expr) )) (defun prolog-toplevel (flattened-clause table) "Replaces some occurences of RELFUNs is-primitive with PROLOGs = . Needed to generate real-PROLOG text." (declare (ignore table)) (mapcar #'(lambda (literal) (cond ((is-t literal) (let ((replacement (list '= (second literal) (third literal)))) ;; literal = (IS vari expr): (cond ((not (consp (third literal))) ;; expr is an atom: replacement) ;; expr is not an atom: ((lisp-function-p (car (third literal))) ;; PROLOG has to evaluate, do not change is: literal ) (t replacement )))) ((and (consp literal) (null (cdr literal))) ;; call without arguments: ;; PROLOG does not like empty parenthesis (car literal) ) (t literal ))) flattened-clause )) (defun rfp-db-2-pl-db (rfp-db table) (mapcar #'(lambda (flattened-clause) (prolog-toplevel flattened-clause table) ) rfp-db )) (pushnew :rf-lisp2pro *features*) ;; ---------------------------------------------------------------------------- ;; End of Module Lisp2Pro.Lsp ;; ---------------------------------------------------------------------------- ;;;### eof ;;;### File "pro2lisp.lisp" ;;; Copyright Notice ;;; ;;; This software is distributed for non-profit and research purposes only. ;;; 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. ;;; ;;; Michael Herfert, Harold Boley (boley@informatik.uni-kl.de) ; ---------------------------------------------------------------------------- ; ; Module Pro2Lisp.Lsp: Contains functions to read goals und clauses ; given in the Prolog-like syntax of Relfun. ; The input can be read from a string or from a ; file of chararacters. ; The output contains the equivalent form in ; the Lisp-like syntax as a symbolic expression. ; ; If an error is detected a message is displayed ; an the value NIL is returned. ; ; ; First Version by Michael Herfert, 2/92 ; For earlier history see lisp2pro.lisp ; 2/97: newsyn for clauses via new impliesepsilon ; 3/97: newsyn for is via point as special-token ; 3/97: new scan-special-item separates after max. special-token ; 9/97: new valued-conjunction top-level implemented by parse-query change [MP] ; ; ; ; Exported items: ; ; ; pro-read-data-base filename [Function] ; ; Assumes that the file contains clauses. ; Returns a list of the clauses in Lisp-like syntax. ; ; ; pro-read-goal string [Function] ; ; Reads in a single goal from a string. ; Note that there is no point at the end of a goal. ; ; ; pro-read-clause string [Function] ; ; Reads in a single clause from the string. ; ; ; pro-split-input string [Function] ; ; Splits the given string in the first symbol and the rest ; of it. Useful for recognizing system-commands. ; Returns a pair. ; Examples: ; (pro-split-input "consult my-base.rfp") ; ==> (consult . "my-base.rfp") ; ; (pro-split-input "[a,b,c]") ; ==> (nil . "") #| #% replaced by (look-for-comment) (for CLiCC) [MS/MP] ;; #. causes read-time-evaluation, important for the compiler. ;; (Steele p. 531/534) #. (set-dispatch-macro-character ; Steele, p. 546ff ;; #% sends a message to the scanner to look for a comment. #\# #\% #'(lambda (stream subchar integer-arg) (declare (ignore subchar integer-arg)) ; subchar is #\% (list 'look-for-comment) )) |# (defun single-char-reader (stream char) (declare (ignore stream)) char ) (defun set-syntax-pro (a-readtable) ;; reading lists: ;; (#'... not allowed on boards!!!) (set-macro-character #\| #+genera 'single-char-reader #-genera #'single-char-reader nil a-readtable) (set-macro-character #\, #+genera 'single-char-reader #-genera #'single-char-reader nil a-readtable) (set-macro-character #\' #+genera 'single-char-reader #-genera #'single-char-reader nil a-readtable) (set-macro-character #\` #+genera 'single-char-reader #-genera #'single-char-reader nil a-readtable) (set-syntax-from-char #\_ #\A a-readtable) a-readtable ) (defvar *rfi-readtable-pro* ; this is a read-only variable (set-syntax-pro (copy-readtable nil)) ) ; nil --> copy of std. readtable ;;; Functions in *extra-parsing-fcts* would have to be additionally ;;; declared (declare-funcallable ...) for CLiCC (defvar *extra-parsing-fcts* nil ;; prepared for future release ;;(list (cons 'inst 'parse-inst)) "Assoc-list of symbols requiring special parsing. Special parsing implies these symbols can not be used for meta-calls. The functions have always this arg-list: (scanner &optional auto-inst-p) " ) ;; ---------------------------------------------------------------------------- (defun signal-error (scanner &rest msg-s) ; Prints all arguments and the error-position via the scanner. (pro-print-error scanner msg-s) (throw :pro-read-error-tag nil) ) ; nil signals an error (defun pro-print-error (scanner msg-s) ; msg-s = (msg-1 msg-2 ..) (rf-terpri) (let ((x (token-x-pos (funcall scanner 'last-token))) (y (token-y-pos (funcall scanner 'last-token))) (last-line (funcall scanner 'last-line)) (act-line (funcall scanner 'act-line)) ) (rf-princ-like-lisp (format nil "Error near line ~A, column ~A.~%" y x )) (mapcar #'(lambda (msg) (if (token-p msg) (if (token-value msg) (rf-princ-like-lisp (token-value msg)) (rf-princ-like-lisp (tok-type->string (token-type msg) ))) (rf-princ-like-lisp msg) )) msg-s ) (rf-terpri) (if (> y 1) (rf-princ-like-lisp last-line) ) (rf-terpri) (rf-princ-like-lisp act-line) (rf-terpri) (rf-terpri) )) (defun tok-type->string (tok-type) ;HB; why without "!" etc.? (case tok-type (round-left (string round-left)) (round-right (string round-right)) (sqr-left (string sqr-left)) (sqr-right (string sqr-right)) (comma (string comma)) (bar (string bar)) (ampersand "&") (implies ":-") (point ".") (is ".=") ;HB; (is "is") (type "type") (colon "colon") (empty "End of input") (t (princ-to-string tok-type)) )) ;; The scanner returns a value of this type: (defstruct token type ; dom = {constant, variable, type, ; round-left, round-right, sqr-left, square-right ;HB; point, comma, ampersand, implies, implies-uc, impliesepsilon ;HB; cut, point, is, colon, empty} value ; used with number, constant, variable. x-pos ; to report an error-position y-pos ) (defun not-equal (x y) (not (eq x y)) ) (defun gen-scanner (the-input-stream) "Returns a scanner-function. The scanner could be seen as an object in the view of OOP. A very big function, but there are many local functions defined by LABELS. " (let ((x-pos 0) (y-pos 1) (char-pos -1) (last-ch #\Space) (last-token (make-token :x-pos 1 :y-pos 1 :type 'empty)) (last-line "") (comment "") (act-line "1: ") (str-of-newlines "") (stacked-tokens nil) ; used e.g. for expanding "!-" to ":-" and "!" (special-tokens ;; special-tokens = (triple-1 .. triple-n) ;; triple = (token-as-string token-type stacked-tokens) '((":-" implies nil) ;; (":-#" implies-uc nil) (":#" implies-uc nil) ; newsyn ;; (":-&" implies (ampersand)) (":&" implies (ampersand)) ; newsyn ;;; (":-!&" implies (cut ampersand)) ;;; (":-!" implies (cut)) ;HB; ("!&" cut (ampersand)) ("!&" impliesepsilon (cut ampersand)) ;implies (neck) or empty (body) ;; ("&!" cut (ampersand)) ; newsyn (abandoned) ("!-" implies (cut)) ;;; ("!-&" implies (cut ampersand)) ("!" cut nil) ("!." cut (point)) ; newsyn for is via next comment requires this ("!-." implies (cut point)) ; and this ("&" ampersand nil) (":" colon nil) (".=" is nil) ; newsyn for is requires: ("." point nil) ; point special-token instead of ... )) ;; terminating characters: ;; (cons ) (terminating-chars (list (cons sqr-left 'sqr-left) (cons sqr-right 'sqr-right) (cons round-left 'round-left) (cons round-right 'round-right) ;(cons #\. 'point) ;... terminating character (cons #\, 'comma) (cons #\| 'bar) (cons #\$ nil) ;;"!" is not a terminating char ("!-") ;(cons #\! 'cut) ;(cons #\& 'ampersand) ))) (labels ((get-ch () (if (char/= last-ch eof-char) (progn (setq last-ch (read-char the-input-stream nil eof-char )) (setq char-pos (1+ char-pos)) (cond ((char= last-ch #\Newline) (setq x-pos 1) (setq y-pos (1+ y-pos)) (setq last-line act-line) (setq act-line (stringcat (princ-to-string y-pos) ": " ))) (t (setq act-line (stringcat act-line (string last-ch))) (setq x-pos (1+ x-pos))) ))) last-ch ) (lookahead () (peek-char nil the-input-stream nil eof-char) ) (scan-item (continue-p &optional (start-str "")) ;; returns a string starting with start-str. (loop (if (and (char/= eof-char last-ch) (funcall continue-p last-ch) ) (setq start-str (stringcat start-str (string last-ch))) (return start-str) ) (get-ch) )) (scan-special-item (&optional (start-str "")) ;HB; stops after... ;; returns a string initialized with start-str = "". (loop (if (and (char/= eof-char last-ch) (special-char-p last-ch) (or (not (member start-str ; ...max. special special-tokens ; tokens :test #'string= ; such as :key #'car )) ; ":&"["-3"], (member (stringcat start-str ; ".="[..], (string last-ch)) ;or special-tokens ; any others, :test #'string= ; even within :key #'car )) ) ; ":-!&" etc. (setq start-str (stringcat start-str (string last-ch))) (return start-str) ) (get-ch) )) (psyn-comment-type-1-reader () ;; reads in the comment and all comments immedeatly following. (let ((triple (read-comments psyn-comment-lead-in 1 ; type of first comment the-input-stream))) (setq comment (stringcat comment (first triple)) y-pos (+ y-pos (second triple)) x-pos (third triple) ))) (psyn-comment-type-2-reader () ;; called at the end of a line to check if the next line ;; begins with a comment. ;; On entry (read-char the-input-stream) returns the first ;; char after #\newline. (unread-char last-ch the-input-stream) (let* ((tuple (read-until-black the-input-stream)) (non-white-char (first tuple)) (triple (if (char= psyn-comment-lead-in non-white-char) (read-comments psyn-comment-lead-in 2 the-input-stream) nil )) ) (setq str-of-newlines (second tuple)) (if triple ;; comment detected: (progn ;(princ "non-w:") (princ non-white-char) (terpri) (setq comment (stringcat str-of-newlines (subseq (first triple) 1) ) str-of-newlines "" ) ; [new] ;(princ "comment=") (princ comment) (princ"<") (terpri) ) ;; no comment at begin of line: (setq x-pos 0) ) )) (id-char-p (ch) (or (id-char-aux-p ch) (char= #\= ch) ;HB;newsyn for is requires: #\= in constants ... (and (char= #\. ch) (id-char-aux-p (lookahead)) ))) (id-char-aux-p (ch) (cond ((both-case-p ch) t) ((digit-char-p ch) t) (t (member ch '(#\+ #\- #\* #\/ #\_ #\< #\> ;HB; #\= ; ... only if not immediately after #\. ) :test #'char=)) )) (special-char-p (ch) (cond ((assoc ch terminating-chars :test #'char=) nil ) ((member ch '(#\; #\' #\`) :test #'char=) nil ) ((char<= ch #\Space) nil) ((char> ch (code-char 127)) nil) ((digit-char-p ch) nil) ((both-case-p ch) nil) (t t) )) (string-constituent-p (ch) (and (not (char= #\" ch)) (not (char= #\Newline ch)) )) (scan-whitespace () (do ((abort nil)) (abort) (case last-ch (#\Space (get-ch)) (#\Newline (if (null *comment-style*) nil (psyn-comment-type-2-reader) ) (get-ch) ; last-ch:= non-comment-char ) (#\Tab (get-ch)) (#\% (if (null *comment-style*) ;; ignore until end of line: (do ((abort nil)) ; comment (abort) (setq abort (char= last-ch #\Newline)) (get-ch) ) ;; read in the type-1-comment: (progn ;; problem: comment at the start of the file ;; is of type-2 without a leading #\Newline (when (and (= 1 x-pos) (= 1 y-pos)) ;; file starts with a comment (setq comment (string #\Newline) )) (psyn-comment-type-1-reader) (get-ch) ; last-ch := non-comment-char ))) (t (setq abort t))))) (scan-digits () ;; digits := digit {digit} ;; returns a string of digits (if (digit-char-p last-ch) (scan-item #'digit-char-p) (signal-error #'scanner (format nil "Expected: digit~%Found: ~C" last-ch )))) (scan-integer () ;; integer := ["+"l"-"] digits ;; returns a string (let ((sign (case last-ch (#\+ (get-ch) "+") (#\- (get-ch) "-") (t "" )))) (stringcat sign (scan-digits)) )) (scan-number-or-silly-symbol () ;; scans reals, rationals and symbols like 1.2.3. ;; returns a number resp. a symbol. ;; real := integer ["." digits] ;; ["E" integer] (let* ((left-side (scan-integer)) (right-side (if (and (char= #\. last-ch) (digit-char-p (peek-char nil the-input-stream nil eof-char))) (progn (get-ch) (stringcat "." (scan-integer)) ) "" )) (exponent (case last-ch ((#\E) (get-ch) (stringcat "E" (scan-integer)) ) (t "") ))) (cond ((and (id-char-p last-ch) (char/= #\/ last-ch) ) ;; a symbol starting with a digit (e.g. 1.2.3 or 12-May) (read-from-string (scan-item #'id-char-p (stringcat left-side exponent right-side )))) ((and (string= "" right-side) (string= "" exponent) (rational-p) ) ;; it's a rational: (scan-rational left-side) ) (t (read-from-string (stringcat left-side right-side exponent )))))) (rational-p () ;; called after an integer has been detected. ;; Value <==> next non-white is a slash (scan-whitespace) (char= #\/ last-ch) ) (scan-rational (numerator-as-string) ;; Condition on entry: last-ch = slash (get-ch) ; eat the slash (scan-whitespace) (read-from-string (stringcat numerator-as-string "/" (scan-integer) ))) (scan-type () ;; On entry: last-ch = char. after "$" (let ((vari-or-symbol (next-token))) (if (eq 'variable (token-type vari-or-symbol)) (list 'typ (list 'vari (token-value vari-or-symbol))) (list 'typ (token-value vari-or-symbol)) ))) (next-token () (let ((r nil) (*readtable* *rfi-readtable-pro*) ) ; dynamic variable (if stacked-tokens (setq r (make-token :type (car stacked-tokens) :x-pos x-pos :y-pos y-pos ) stacked-tokens (cdr stacked-tokens) ) (progn (scan-whitespace) (setq r (make-token :x-pos x-pos :y-pos y-pos)) (cond ((digit-char-p last-ch) (setf (token-type r) 'constant) (if (char= #\1 last-ch) ;; check for functors 1- and 1+ (case (peek-char nil the-input-stream nil eof-char) (#\+ (setf (token-value r) '1+) (get-ch) (get-ch) ) (#\- (setf (token-value r) '1-) (get-ch) (get-ch) ) (t (setf (token-value r) (scan-number-or-silly-symbol)))) (setf (token-value r) (scan-number-or-silly-symbol) ))) ((or (lower-case-p last-ch) (member last-ch '(#\* #\/)) ) (setf (token-value r) (read-from-string (scan-item #'id-char-p)) ) ;HB; old is (if (eq 'is (token-value r)) ;HB; forbidden (setf (token-type r) 'is ;HB; with ".=" (token-value r) nil ) (setf (token-type r) 'constant) ;HB; ) ) ((upper-case-p last-ch) (setf (token-type r) 'variable) (setf (token-value r) (read-from-string (scan-item #'id-char-p)) )) ((char= #\_ last-ch) (get-ch) ; read the underscore (cond ((digit-char-p last-ch) (setf (token-type r) 'variable (token-value r) (intern (scan-digits)))) ((lower-case-p last-ch) (setf (token-type r) 'variable (token-value r) (read-from-string (scan-item #'id-char-p )))) ((upper-case-p last-ch) (signal-error #'scanner "Uppercase-letter not allowed after _")) (t ; anonymous variable (setf (token-type r) 'variable (token-value r) '_ )))) ((char= #\$ last-ch) (if (id-char-p (get-ch)) (setf (token-type r) 'type (token-value r) (scan-type) ) (signal-error #'scanner (format nil "symbol or variable expected" )))) ((char= #\" last-ch) ;;(setf (token-type r) 'string) (setf (token-type r) 'constant) (get-ch) ; read opening quote (setf (token-value r) (scan-item #'string-constituent-p) ) (if (char= #\" last-ch) (get-ch) ; read closing quote (signal-error #'scanner (format nil "Expected: \"~%Found: ~C" last-ch )))) #| ;; Problems with keywords in the tracer ! ((and (char= #\: last-ch) (lower-case-p (lookahead)) ) ;; look for a keyword (e.g. :incl) (get-ch) ; read the colon (setf (token-value r) (read-from-string (stringcat ":" (scan-item #'id-char-p ))) (token-type r) 'constant) ) |# ((or (char= #\+ last-ch) (char= #\- last-ch) ) (cond ((digit-char-p (peek-char nil the-input-stream nil eof-char)) ;;(setf (token-type r) 'number) (setf (token-type r) 'constant (token-value r) (scan-number-or-silly-symbol) )) (t (setf (token-type r) 'constant (token-value r) (read-from-string (scan-item #'id-char-p)))))) ((special-char-p last-ch) ;; read in a max. sequence of special-chars (let* ((str (scan-special-item)) ;HB; see def. (triple (car (member str special-tokens :test #'string= :key #'car )))) (if triple (setf (token-type r) (second triple) stacked-tokens (third triple) ) (setf (token-type r) 'constant (token-value r) (read-from-string str) ) ))) ((char= eof-char last-ch) (setf (token-type r) 'empty) ) (t (let ((pair-of-char-and-type (assoc last-ch terminating-chars) )) (if pair-of-char-and-type (progn (setf (token-type r) (cdr pair-of-char-and-type)) (get-ch) ) (signal-error #'scanner (format nil "Illegal character: ~C" last-ch )))))))) (setq last-token r) r )) (continue-after-error () ;; searches for the next token after a point. (setq stacked-tokens nil) (when *comment-style* (setq last-ch (peek-char nil the-input-stream nil eof-char)) ) (loop (case (token-type last-token) (point (return (next-token))) (empty (return last-token)) (t (next-token)) )) ) (scanner (&optional (message 'next-token)) (case message (next-token (next-token)) (last-token last-token) (last-token-type (token-type last-token)) (last-token-value (token-value last-token)) (comment-p (string/= "" comment)) (comment (prog1 comment (setq comment ""))) (str-of-newlines-p (string/= "" str-of-newlines)) (str-of-newlines (prog1 str-of-newlines (setq str-of-newlines "") )) (x-pos x-pos) (y-pos y-pos) (last-line last-line) (act-line act-line) (last-char last-ch) (continue-after-error (continue-after-error)) (pos-of-first-non-white (scan-whitespace) char-pos ) (t (internal-error "unknown message in scanner" message)) ))) ; init variables: (get-ch) (next-token) #'scanner ; value of gen-scanner-from-fct ))) ;; Following two meta-rules to obtain a clear structure: (defun parse-general-loop ( scanner syntax-rule first-of-syntax-rule &optional auto-inst-p ) ; Parses a construct of the form: ; syntax-rule {syntax-rule} ; where first(syntax-rule) = first-of-syntax-rule. ; syntax-rule is a parser-function, first-of-syntax-rule is a token-type. ; Returns a list of the results (do ((l (list (funcall syntax-rule scanner auto-inst-p)) (append l (list (funcall syntax-rule scanner auto-inst-p))) )) ((not-equal first-of-syntax-rule (funcall scanner 'last-token-type) ) l) )) (defun parse-general-enumeration (scanner syntax-rule &optional auto-inst-p) ;; Parses a construct of the form: ;; syntax-rule {"," syntax-rule} ;; where syntax-rule is a parser-function. ;; Returns a list of the results. ;; Comments: on entry: yes; on exit: no; (do* ((list-of-items (clist (look-for-comment)) (append list-of-items (clist item (look-for-comment)))) (item (funcall syntax-rule scanner auto-inst-p) (funcall syntax-rule scanner auto-inst-p) )) ((not-equal (token-type (funcall scanner 'last-token)) 'comma) (append list-of-items (clist item (look-for-comment))) ) (accept-token-type 'comma) )) (defun parse-clause (scanner) ;; clause ::= head ( "." ;; \| ":-" [body] "." ;; \| ":#" [body] "." ;;HB; \| ... [body] "." ;; ) ;; Comments: on entry: no; on exit: yes. (let* ((head (parse-head scanner)) (tok-type (funcall scanner 'last-token-type)) ) (funcall scanner) ; accept the symbol between head and body (case tok-type ;; (point (clist 'hn head )) ; horn-fact (point (if (atom head) (clist 'md head) ; include file (clist 'hn head )) ) ; horn-fact ;HB; (implies (if (eq 'point (funcall scanner 'last-token-type)) ;rule (cut (prog1 (clist 'hn head (look-for-comment) '\!) ; 'hn-cutfact' (accept-token-type 'point))) ; has just cut and then point ((implies impliesepsilon) ; as neck, impliesepsilon acts like implies ; with something (cut ampersand) as stacked-tokens (if (eq 'point (funcall scanner 'last-token-type)) ;rule ;; empty body: (prog1 (clist 'hn head (look-for-comment)) ; comment after head (accept-token-type 'point) ) (prog1 (parse-the-body scanner head) (accept-token-type 'point) ))) (implies-uc (prog1 (parse-the-body scanner head 'uc) (accept-token-type 'point) )) (t (signal-error scanner "Unknown symbol between head and body: " tok-type ))))) (defun parse-head (scanner) ;; head ::= term [round-list-with-terms] ;; Comments: on entry: no; on exit: yes. ;; (cons (parse-term scanner t) ; t means auto-inst-p ;; (parse-round-list-with-terms scanner) ) (let ((the-term (parse-term scanner t))) (if (and (eq 'point (funcall scanner 'last-token-type)) (atom the-term) ) ;; symbol-fact: the-term (cons the-term (parse-round-list-with-terms scanner)) ))) (defun parse-the-body (scanner head &optional (type-of-clause 'hn)) ;; On entry: body is non-empty. ;; body ::= [expr+] ( "!" [expr+] ["&" expr] ;; \| "&" expr ["!"] ;; \| "&" "!" expr ;; ) ;; Returns a horn- or a footed-rule. ;; Note: PARSE-BODY is a reserved symbol in LUCID-Lisp. (let (;;(type-of-clause 'hn) (comment-after-head (look-for-comment)) (body nil) ) (case (funcall scanner 'last-token-type) ;HB; ((cut ampersand)) ((cut ampersand impliesepsilon)) (t (setq body (parse-expr+ scanner))) ) ; parse-expr+ accepts comments (case (funcall scanner 'last-token-type) (cut (accept-token-type 'cut) (setq body (append body (clist '\! (look-for-comment)))) (case (funcall scanner 'last-token-type) ((ampersand point)) (t (setq body (append body (parse-expr+ scanner)))) ) (when (eq 'ampersand (funcall scanner 'last-token-type)) (accept-token-type 'ampersand) (setq body (append body (clist (look-for-comment) (parse-expr scanner) (look-for-comment))) type-of-clause 'ft ))) (ampersand (accept-token-type 'ampersand) (setq type-of-clause 'ft ) (if (eq 'cut (funcall scanner 'last-token-type)) (progn ; "&" "!" : ; newsyn (accept-token-type 'cut) (setq body (append body '(\!) (clist (look-for-comment) (parse-expr scanner) (look-for-comment))))) (progn ;; "&" : (setq body (append body (clist (look-for-comment) (parse-expr scanner) (look-for-comment)))) (when (eq 'cut (funcall scanner 'last-token-type)) (accept-token-type 'cut) (setq body (append body (clist (look-for-comment) '\! (look-for-comment)))) )))) (impliesepsilon (accept-token-type 'impliesepsilon) ; as body part, ; impliesepsilon acts like an empty string but accepts ; immediately following stacked-tokens (cut ampersand) (accept-token-type 'cut) (accept-token-type 'ampersand) (setq type-of-clause 'ft ) (setq body (append body (clist '\! (look-for-comment) (parse-expr scanner) (look-for-comment)))) ) (t) ) (cons type-of-clause (append (clist head comment-after-head) body) ))) (defun parse-expr (scanner &optional auto-inst-p) ;; expr ::= ( term [ {round-list} ;; | IS expr ;; ] ;; | builtin ;; ) ;; Comments: on entry: no; on exit: yes. ;;(declare (ignore auto-inst-p)) (let ((r (parse-term scanner))) (case (funcall scanner 'last-token-type) (is (accept-token-type 'is) (clist 'is (remove-non-var-inst r) (look-for-comment) (parse-expr scanner) (look-for-comment))) (round-left (let-assoc (parser-fct r *extra-parsing-fcts*) (parser-fct scanner auto-inst-p) (construct-application r (parse-general-loop scanner #'parse-round-list 'round-left )))) (t r) ))) (defun parse-term (scanner &optional auto-inst-p) ;; term ::= ( CONSTANT ;; | VARIABLE ;; | TYPE ;; | sqr-list ;; ) ;; [ (":" term) | {sqr-list} ] ;; If auto-inst-p is t then no explicit inst-tag is generated. ;; Needed for terms in the head of a rule and for nested lists. ;; Comments: on entry: no; on exit: yes. (let ((tok (funcall scanner 'last-token)) (l nil) (sqr-left-p nil) ) (case (token-type tok) (constant (setq l (token-value tok)) (accept-token-type 'constant)) (variable (setq l (parse-variable scanner))) (type (setq l (token-value tok)) (accept-token-type 'type)) (sqr-left (setq l (cons 'tup (parse-sqr-list scanner t)) sqr-left-p t )) (t (signal-error scanner (format nil (stringcat "Constant, variable or [ expected." "~%Found: " )) tok ))) (case (funcall scanner 'last-token-type) (sqr-left (setq l (construct-application l ; comment after sqr-left: (parse-general-loop scanner #'parse-sqr-list 'sqr-left t ) ) sqr-left-p t )) (colon (accept-token-type 'colon) (setq l (mk-typed-expr l (parse-term scanner)))) ) (if (and (not auto-inst-p) sqr-left-p ) (setq l (list 'inst l)) ) l )) (defun parse-round-list (scanner &optional auto-inst-p) ;; round-list ::= "(" [expr+] ["|" expr] ")" ;; Comments: on entry: yes; on exit: yes; (accept-token-type 'round-left) (let ((l (clist (look-for-comment)))) ; no comment ==> l is empty (case (funcall scanner 'last-token-type) (bar ) (round-right ) (t (setq l (append l (parse-expr+ scanner)))) ) (when (eq 'bar (funcall scanner 'last-token-type)) (setq l (append l (clist (look-for-comment) '\| (progn (accept-token-type 'bar) (look-for-comment)) (parse-expr scanner auto-inst-p)) ))) (accept-token-type 'round-right) l )) (defun parse-sqr-list (scanner &optional auto-inst-p) ;; sqr-list ::= "[" [term+] ["|" term] "]" ;; Comments: on entry: yes; on exit: yes; (accept-token-type 'sqr-left) (let ((l (clist (look-for-comment)))) ; no comment ==> l is empty (case (funcall scanner 'last-token-type) (bar ) (sqr-right ) (t (setq l (append l (parse-term+ scanner auto-inst-p)))) ) (when (eq 'bar (funcall scanner 'last-token-type)) (setq l (append l (clist (look-for-comment) '\| (progn (accept-token-type 'bar) (look-for-comment)) (parse-term scanner auto-inst-p) )))) (accept-token-type 'sqr-right) l )) (defun parse-round-list-with-terms (scanner) ;; round-list-with-terms ::= "(" [term+] ["|" VARIABLE] ")" ;; Comments: on entry: yes; on exit: yes; (accept-token-type 'round-left) (let ((l (clist (look-for-comment)))) ; no comment ==> l is empty (case (funcall scanner 'last-token-type) (bar ) (round-right ) (t (setq l (append l (parse-term+ scanner t)))) ) (when (eq 'bar (funcall scanner 'last-token-type)) (setq l (append l (clist (look-for-comment) '\| (progn (accept-token-type 'bar) (look-for-comment)) (parse-variable scanner)) ))) (accept-token-type 'round-right) l )) (defun parse-expr+ (scanner &optional auto-inst-p) ;; expr+ ::= expr {"," expr} ;; Returns a list of results. ;; auto-inst-p is not used in this function. ;; Comments: on entry: yes; on exit: no; (declare (ignore auto-inst-p)) (parse-general-enumeration scanner #'parse-expr) ) (defun parse-term+ (scanner &optional auto-inst-p) ;; term+ ::= term {"," term} ; Returns a list of results. ;; Comments: on entry: yes; on exit: no; (parse-general-enumeration scanner #'parse-term auto-inst-p) ) (defun parse-variable (scanner) ;; Comments: on entry: yes; on exit: no; (let ((var-name (funcall scanner 'last-token-value))) (accept-token-type 'variable) (if (eq '_ var-name) 'id ; anonymous variable (list 'vari var-name) ))) (defun parse-goal (scanner) " goal ::= ('!' expr+ ['&' expr]) | (expr+ ['!' expr*]['&' expr]) Problem on syntax [to do]: Imagine a batch file containing this two lines: f(X) ! g(Y) One goal or two goals ? The current implementation constructs two goals. To change this modify the var cont-chars in the function pro-complete-cmd-p (rfi.lisp). " (if (eq 'cut (funcall scanner 'last-token-type)) (progn (accept-token-type 'cut) (cons '\! (parse-expr+ scanner)) ) (let ((result (parse-expr+ scanner))) (when (eq 'cut (funcall scanner 'last-token-type)) (setq result (append result '(\!))) (accept-token-type 'cut) (unless (eq 'empty (funcall scanner 'last-token-type)) (setq result (append result (parse-expr+ scanner))) )) (if (eq 'ampersand (funcall scanner 'last-token-type)) ; MP: valued-conjunction top-level (progn (accept-token-type 'ampersand) (setq result (append result (list (parse-expr scanner))))) (if (> (length result) 1) (setq result (append result '(true))))) result ))) (defun construct-application (functor list-of-arg-lists) ; Example: functor = f ; list-of-args-lists = ((a b) (x y)) ; Result: ((f a b) x y) (if (null list-of-arg-lists) functor (construct-application (cons functor (car list-of-arg-lists) ) (cdr list-of-arg-lists) ))) (defun remove-non-var-inst (term) ;; removes a possibly existing INST-tag if is not followed by a variable. (if (and (consp term) (inst-t term) (not (vari-t (second term))) ) (second term) ; remove inst term )) (defun clist (&rest args) ;; Like list but takes care of comments: ;; If one of the args is a com-cell with empty string-fields ;; then it will be not included in the list. (let (the-list) (dolist (element args (reverse the-list)) (unless (and (com-cell-p element) (or (null *comment-style*) (and (string= "" (com-cell-pre-txt element)) (string= "" (com-cell-post-txt element)) ))) ;; don't ignore the element: (setq the-list (cons element the-list)) )))) (defun pro-parse-head (head-as-string) (with-input-from-string (the-input-stream head-as-string) (catch :pro-read-error-tag (parse-head (gen-scanner the-input-stream)) ))) ;; -------------------- Exported functions: --------------------------------- (defun pro-parse-head-functor (head-functor-as-string) (with-input-from-string (the-input-stream head-functor-as-string) (catch :pro-read-error-tag (parse-term (gen-scanner the-input-stream) t) ))) (defun pro-read-data-base (filename) (with-open-file (the-input-stream filename :direction :input) (pro-read-data-base-from-stream the-input-stream) )) (defun pro-read-data-base-from-stream (the-input-stream) (catch :pro-read-error-tag (let ((scanner (gen-scanner the-input-stream)) (clause nil) (data-base nil) (error-p nil) ) (loop (if (eq 'empty (funcall scanner 'last-token-type)) (if error-p (return nil) (return (reverse data-base)) )) (setq clause (catch :pro-read-error-tag (parse-clause scanner) )) (cond ((null clause) ;; Error (setq error-p t) (rf-terpri) (rf-princ-like-lisp "Continue reading to find more") (rf-princ-like-lisp " errors in line ") (funcall scanner 'continue-after-error) (rf-princ-like-lisp (token-y-pos (funcall scanner 'last-token ))) (rf-princ-like-lisp ".") (rf-terpri) ) (error-p ;; Error in previous clause --> don't construct database ) (t ;; No error (setq data-base (cons clause data-base)) )))))) (defun pro-read-clause (str) (catch :pro-read-error-tag (with-input-from-string (the-input-stream str) (let* ((scanner (gen-scanner the-input-stream)) (clause (parse-clause scanner)) ) (cond ((null clause) ;; Error nil ) ((eq 'empty (funcall scanner 'last-token-type)) ;; all of the input is o.k. (if *comment-style* (hide-comments clause) clause )) (t (pro-print-error scanner (list "Only the first part of the input is correct.")) nil )))))) (defun pro-read-goal (str) "Reads a goal from the toplevel. See also function parse-goal. " (catch :pro-read-error-tag (with-input-from-string (the-input-stream str) (let* ((scanner (gen-scanner the-input-stream)) (goal (parse-goal scanner)) ) (cond ((null goal) ;; Error nil ) ((eq 'empty (funcall scanner 'last-token-type)) ;; all of the input is o.k. (if *comment-style* (hide-comments goal) goal )) ((eq 'point (funcall scanner 'last-token-type)) (pro-print-error scanner (list "Illegal point at the end of a goal.") ) nil ) (t (pro-print-error scanner (list "Only the first part of the input is correct.") ) nil )))))) #| (defun pro-read-goal (str) ; goal ::= expr {"," expr} (catch :pro-read-error-tag (with-input-from-string (the-input-stream str) (let* ((scanner (gen-scanner the-input-stream)) (goal (parse-general-enumeration scanner #'parse-expr)) ) (cond ((null goal) ;; Error nil ) ((eq 'empty (funcall scanner 'last-token-type)) ;; all of the input is o.k. (if *comment-style* (hide-comments goal) goal )) ((eq 'point (funcall scanner 'last-token-type)) (pro-print-error scanner (list "Illegal point at the end of a goal.") ) nil ) (t (pro-print-error scanner (list "Only the first part of the input is correct.") ) nil )))))) |# (defun pro-split-input (input-line) ; Examples: ; ; (pro-split-input "consult my-base.rfp") ; ==> (consult . "my-base.rfp") ; ; (pro-split-input "[a,b,c]") ; ==> (nil . "") ; (catch :pro-read-error-tag (with-input-from-string (the-input-stream input-line) (let* ((scanner (gen-scanner the-input-stream)) (tok (funcall scanner 'last-token)) ) (if (and (eq 'constant (token-type tok) ) (symbolp (token-value tok)) ) (cons (token-value tok) (subseq input-line (funcall scanner 'pos-of-first-non-white) )) (cons nil "") ))))) (defun pro-parse-trace-cmd (str) ;; trace-cmd = { head-functor ;; { :INCL int-list | :EXCL int-list | :STATUS ;; | :PRINT-P symbol | :PRINT-F symbol ;; }} (catch :pro-read-error-tag (with-input-from-string (the-input-stream str) (do* ((scanner (gen-scanner the-input-stream)) (one-proc nil (pro-parse-trace-cmd-1 scanner)) (result nil (append result one-proc)) ) ((eq 'empty (funcall scanner 'last-token-type)) result ) )))) (defun pro-parse-trace-cmd-1 (scanner) "Parses the description of one procedure to trace." (do* ((head-functor (parse-term scanner t)) (result (list head-functor) (append result item)) (item) (abort-p) (tok-value (funcall scanner 'last-token-value) (funcall scanner 'last-token-value) ) ) (abort-p result) (case tok-value ((:incl :excl) (accept-token-type 'constant) (setq item (cons tok-value (pro-parse-trace-cmd-2 scanner) ))) ((:print-p :print-f) (accept-token-type 'constant) (setq item (list tok-value (parse-term scanner t))) ) (:status (accept-token-type 'constant) (setq item (list :status)) ) (t (setq abort-p t item nil ) )))) (defun pro-parse-trace-cmd-2 (scanner) "parses: ALL | integer {integer}" (if (eq 'all (funcall scanner 'last-token-value)) (progn (accept-token-type 'constant) (list 'all) ) (do* ((integers nil (cons tok-value integers)) (tok-value (funcall scanner 'last-token-value) (funcall scanner 'last-token-value) )) ((not (numberp tok-value)) (reverse integers) ) (accept-token-type 'constant) ))) (pushnew :rf-pro2lisp *features*) ;; ---------------------------------------------------------------------------- ;; End of module Pro2Lisp.Lsp ;; ---------------------------------------------------------------------------- ;;;### eof