;;; -*- Mode: Lisp; Package: Prolog; Base: 10. ; -*- ;;; (C) Copyright 1983,1984,1985, Uppsala University ;;This is the top level of LM-Prolog (defvar *window-alist* () "An alist of ( . )") (defun reset-prolog () (mapc #'(lambda (pair) (eval-in-window (car pair) '(setq *prolog-level* 0 *possibilities* () *possibilities-stack* () *mark* 0 *mark-stack* ()))) *window-alist*) #-symbolics (array-initialize *original-trail-array* nil) #+symbolics (fillarray *original-trail-array* '(nil)) (setq *prolog-work-area* nil *cut-tag* 'top-level-cut-tag *conses-alist* () *vector* *original-vector* *trail-array* *original-trail-array*) (link-*trail*-count) (setq *trail* 0) #+PROLOG-MICRO-CODE (LOAD-MICROCODE) ;;This wants things above to have decent values... (set-circularity-mode *circularity-mode*) ;;After above since it touches processor memories (cond ((not (universe-ok *universe*)) (format t "There is something wrong with the universe ~S, being reset to (:user :system)" *universe*) (set-universe '(:user :system)))) (step-off) ) (add-initialization "Re-setting the Prolog Top Level" '(reset-prolog) '(:warm)) ;; These (and a few more) are maintained per window. ;; Delete global initialization for the few more? Needed at compile time though. (defvar *prolog-level* ':unbound "Recursive Prolog level counter.") (defvar *possibilities* ':unbound "An instance for getting more proofs, or NIL.") (defvar *possibilities-stack* ':unbound "A stack of possibilities for recursive levels.") (defvar *mark* ':unbound "The point to which to reset the trail for this level.") (defvar *mark-stack* ':unbound "A stack of trail pointers for recursive levels.") (defvar *language* ':unbound ":lisp or :prolog") (DEFF GENERIC-EVAL #-symbolics #'si:EVAL-ABORT-TRIVIAL-ERRORS #+symbolics #'eval) (deffun eval-in-window (window form) (cond ((assq window *window-alist*) (funcall (cdr (assq window *window-alist*)) form)) (t (let ((name (make-symbol (format nil "PROLOG-WORK-AREA-FOR-~A" window) t))) (push (cons window (let-closed ((A-TRAIL-ARRAY (allocate-resource 'trail 10000.)) (A-WORK-AREA #+(or cadr symbolics) (make-area ':name name ':gc ':temporary ':region-size #o200000 ;;1/256 virtual memory ':representation ':list ;;for initial region ) #-(or cadr symbolics) (make-area ':name name ':gc ':dynamic ':volatility 3 ':region-size #o200000 ;;1/256 virtual memory ':representation ':list ;;for initial region ) ) (*prolog-level* 0) (*possibilities* ()) (*possibilities-stack* ()) (*mark* 0) (*mark-stack* ()) (*global-names* ()) (*language* ':lisp)) #'(LAMBDA (X) (LET ((*TRAIL-ARRAY* A-TRAIL-ARRAY) (*PROLOG-WORK-AREA* A-WORK-AREA)) (GENERIC-EVAL X))))) *window-alist*) (eval-in-window window form))))) ;;; These macros are useful in a number of applications #-lexical (defmacro remind (who operation &rest args) `(trail (continuation (send ,who ,operation . ,args)))) #+lexical (defmacro remind (who operation &rest args) (let ((bindings (mapcar #'(lambda (value) (list (gensym) value)) args))) `(let ((who ,who) . ,bindings) (trail (continuation (send who ,operation . ,(mapcar 'car bindings))))))) #-lexical (defmacro remind-call (what &rest args) `(trail (continuation (funcall ,what . ,args)))) #+lexical (defmacro remind-call (what &rest args) (let ((bindings (mapcar #'(lambda (value) (list (gensym) value)) args))) `(let ,bindings (trail (continuation (funcall ,what . ,(mapcar 'car bindings))))))) ;;This is the body of the top-level loop. ;;It converts the Lisp form just read into a Prolog structure ;;and "interns" the variables in the predication. ;;It binds the variables to their current values ;;so that upon abnormal return they are restored (defun set-global-names (value) (setq *global-names* value)) (defun top-level-prove-and-show-results (predication) (ESTABLISH-CONDITION-HANDLERS (with-trail *trail-array* (cond (*mark* (with-who-line "Untrail" (untrail *mark*))) (t (setq *mark* *trail*))) (cond ((zerop *trail*) (new-problem-clean-up))) (remind-call 'set-global-names *global-names*) (cond ((eq *language* ':lisp) (GENERIC-EVAL predication)) (t ;(send *possibilities* ':flush) (top-level-prove-and-show-results-body predication)))))) (defun new-problem-clean-up () ;;Nothing should be pointing into the Prolog work area so re-set it (cond ((temporary-area-p *prolog-work-area*) (si:reset-temporary-area *prolog-work-area*)) (t (setf (aref *value-cell-names-array* *prolog-work-area*) nil)))) (advise si:reset-temporary-area :before "Cleanup for Prolog" nil (setf (aref *value-cell-names-array* (car arglist)) nil)) (compile-encapsulations 'si:reset-temporary-area) (deffun top-level-prove-and-show-results-body (lisp-predication) (cond ((and (atom lisp-predication) (assq lisp-predication *global-names*)) (top-level-prove-and-show-results-body (cdr (assq lisp-predication *global-names*)))) ((atom lisp-predication) (setq *possibilities* (make-instance-in-area *prolog-work-area* 'top-level-prolog-query ':term lisp-predication ':trail *trail-array* ':mark *mark* ':work-area *prolog-work-area* ':return-trail-p nil ':cells () ':variable-names () ':proof-stream (continuation (funcall (atom-as-predication-prover lisp-predication) (continuation (continuation (false))))))) (possibilities-body)) ((null (current-definition ':top-level-predication nil)) (setq *possibilities* (make-query lisp-predication ':trail *trail-array* ':mark *mark* ':area *prolog-work-area* ':lisp-term t ':top-level t ':print-results t ':global-variables-p t)) (possibilities-body)) (t (setq *possibilities* (make-query `(:top-level-predication ,lisp-predication) ':trail *trail-array* ':mark *mark* ':area *prolog-work-area* ':lisp-term t ':top-level t ':global-variables-p t)) (possibilities-body)))) ;;the bindings of the variables in the user's predication are presented ;;this is a way to call the theorem prover from Lisp ;; The flavor PROLOG-QUERY accepts messages :NEXT-ANSWER and :FLUSH ;; :NEXT-ANSWER returns NIL or ;; :FLUSH restores everything ;; Computes in "work-area" and conses answer in default-cons-area. (defflavor prolog-query (term trail return-trail-p mark proof-stream work-area (succeeded nil)) () :initable-instance-variables) (defmethod (prolog-query :flush) () (let ((*prolog-work-area* work-area)) (cond (trail (with-trail trail (setq proof-stream (progn (untrail mark) ()))) (cond (return-trail-p (deallocate-a-trail trail))) (setq trail nil))))) (defmethod (prolog-query :next-answer) () (cond ((null proof-stream) nil) (t (let ((*prolog-work-area* work-area)) (*catch *cut-tag* (with-trail trail (setq proof-stream (invoke proof-stream))))) (cond ((null proof-stream) nil) (t (let ((*prolog-work-area* default-cons-area)) (setq succeeded t) (values (lisp-form (%dereference term) ':copy) t))))))) (defmethod (prolog-query :show-results) () ()) ;;dummy method (defflavor top-level-prolog-query (variable-names cells) (prolog-query) :initable-instance-variables) (defmethod (top-level-prolog-query :show-results) () (cond ((null proof-stream) (let ((*prolog-work-area* work-area)) (with-trail trail (with-who-line "Untrail" (untrail mark)))) (cond (succeeded (format t "~&No more answers")) (t (format t "~&No answer"))) nil) (t (format t "~&OK") (print-bindings variable-names cells)))) (defun print-bindings (variables-left values) (print-bindings-1 variables-left values)) ;;USED TO BIND *VALUE-CELL-NAMES* (deffun print-bindings-1 (variables-left values) (cond ((not (null variables-left)) (let ((variable (first variables-left))) (cond ((anonymous variable)) (t (let ((value (lisp-form-1 (first values) *default-lisp-form-mode*))) (format t "~%~S = " variable) (FUNCALL (OR PRIN1 #'PRIN1) VALUE))))) (print-bindings-1 (rest1 variables-left) (rest1 values))))) (defun query-once (lisp-predication &optional &key (lisp-term lisp-predication) (global-variables-p nil)) (let ((stream (make-query lisp-predication ':lisp-term lisp-term ':trail *trail-array* ':mark *trail* ':area *prolog-work-area* ':deterministic t ':global-variables-p global-variables-p))) (multiple-value-bind (value succeeded-p) (send stream ':next-answer) (send stream ':flush) (values value succeeded-p)))) (defun make-query (lisp-predication &optional &key (lisp-term lisp-predication) (size 500.) (TRAIL) (mark 0) (area default-cons-area) (deterministic nil) (top-level nil) (print-results nil) (global-variables-p nil)) (cond ((atom lisp-predication) (prolog-error ':atom-as-predication "~s, which is not a list, given as a predication." lisp-predication))) (let* ((*prolog-work-area* area) (*parse-alist* ()) (OLD-TRAIL-P TRAIL) (TRAIL (OR OLD-TRAIL-P (ALLOCATE-resource 'trail SIZE))) (predication (parse-term-1 lisp-predication global-variables-p)) (term (cond ((eq lisp-predication lisp-term) predication) (t (parse-term-1 lisp-term global-variables-p)))) (definition (current-definition (first predication))) (prover (definition-prover definition)) (proof-stream (cond ((or deterministic (definition-deterministic definition)) ;;important optimization (continuation (lexpr-funcall prover (continuation (continuation (false))) (rest1 predication)))) (t (let* ((csg si:%current-stack-group) (continuation (continuation (funcall #'stack-group-resume csg t))) (coroutine (with-trail trail (allocate-a-coroutine prover continuation (rest1 predication) top-level)))) (continuation (funcall #'resume coroutine))))))) (cond (print-results (make-instance-in-area area 'top-level-prolog-query ':term term ':trail trail ':mark mark ':work-area area ':cells (variables-in *parse-alist*) ':variable-names (variable-names-in *parse-alist*) ':return-trail-p (not old-trail-p) ':proof-stream proof-stream)) (t (make-instance-in-area area 'prolog-query ':term term ':trail trail ':mark mark ':work-area area ':return-trail-p (not old-trail-p) ':proof-stream proof-stream))))) (defun resume (sg) (cond ((si:sg-resumable-p sg) ;;can be in a bad state due to [abort] (detach sg (funcall sg nil))))) ;;NIL will force coroutine to backtrack (deffun detach (sg msg) (cond ;;This is for fancy inter-stack-group communication that was used once with ZTOP. ; ((and #-symbolics ( sys:sg-state-exhausted (sys:sg-current-state sg)) ; #+symbolics (zerop (si:sg-exhausted-bit sg)) ; (consp msg)) ; (detach sg ; (funcall sg ; (multiple-value-list ;;Some methods m-v-return, e.g. CURSORPOS ; (cond ((eq ':rubout-handler (second msg)) ; (funcall (symeval (first msg)) ; (second msg) ; (third msg) ; (fourth msg) ; (symeval (first msg)) ; (nth 5 msg))) ; (t (apply (symeval (first msg)) (rest1 msg)))))))) ((null msg) nil) (t (continuation (funcall #'resume sg))))) (defvar *top-level-regpdl-size* 20000.) ;;for user customizations... (defvar *coroutine-regpdl-size* #o10000) (defvar *top-level-specpdl-size* 2000.) (defvar *coroutine-specpdl-size* #o1000) (defresource coroutine (reg spec) :constructor (list (make-stack-group 'prolog-coroutine ':regular-pdl-size reg ':special-pdl-size spec) ;;the following is the *vector* of the process ;;it is long enough for 4 recursive entries to %unify-term-with-template ;;this happens currently only when unifying constraints or clauses (make-list 256. ':area permanent-storage-area))) (defun coroutine-closure-function #.*variables-shared-between-top-level-stack-groups* (establish-condition-handlers (*catch *cut-tag* (catch-error-restart ((sys:abort error) "Terminate and return to Prolog top level") (with-trail *trail-array* (lexpr-funcall function continuation arglist)))))) (defun allocate-a-coroutine (function continuation arglist &optional top-level-p) (let (stack-group-and-vector) (unwind-protect (progn (setq stack-group-and-vector (cond (top-level-p (allocate-resource 'coroutine *top-level-regpdl-size* *top-level-specpdl-size*)) (t (allocate-resource 'coroutine *coroutine-regpdl-size* *coroutine-specpdl-size*)))) (let* ((stack-group (first stack-group-and-vector)) (*vector* (second stack-group-and-vector))) (cond ( ;top-level-p t (stack-group-preset stack-group #'coroutine-closure-function . #.*variables-shared-between-top-level-stack-groups*)) (t ;;should close over *universe*, *default-lisp-form-mode* too. ;;The problem is that funny toplevels prove their predications ;;inside of lazy collections, and so ADD-WORLD etc. wouldn't ;;work with those toplevels. (stack-group-preset stack-group #'coroutine-closure-function . #.*variables-shared-between-stack-groups*))))) (and stack-group-and-vector (trail (continuation (funcall #'deallocate-a-coroutine stack-group-and-vector))))))) (defun deallocate-a-coroutine (stack-group-and-vector) #-symbolics (eh:sg-unwind (car stack-group-and-vector) t eh:%current-stack-group nil ;;Using %current-stack-group or #'stack-group-return as "action" doesnt win! #'(lambda (x) (stack-group-resume x nil)) 'eh:free) #+symbolics (dbg:unwind-sg (car stack-group-and-vector) #'(lambda (x) (stack-group-resume x nil)) dbg:%current-stack-group nil) (deallocate-resource 'coroutine stack-group-and-vector)) ;;This is for fancy inter-stack-group communication that was used once with ZTOP. ;(defvar coroutine-without-io ; (let-closed ; ;;a special handler to make IO happen in original stack group. ; ((terminal-io ; #'(lambda (&rest args) ; (values-list ; (stack-group-return ; (cons-in-area 'terminal-io args *prolog-work-area*))))) ; (standard-input ; #'(lambda (&rest args) ; (values-list ; (stack-group-return ; (cons-in-area 'standard-input args *prolog-work-area*))))) ; (standard-output ; #'(lambda (&rest args) ; (values-list ; (stack-group-return ; (cons-in-area 'standard-output args *prolog-work-area*))))) ; (query-io ; #'(lambda (&rest args) ; (values-list ; (stack-group-return ; (cons-in-area 'query-io args *prolog-work-area*)))))) ; #'coroutine-closure-function)) (defmacro advise-within-each (list-within-functions &rest arguments) `(progn ,@(mapcar #'(lambda (within-function) `(advise-within ,within-function ,@arguments)) list-within-functions))) (defmacro unadvise-within-each (list-within-functions &rest arguments) `(progn ,@(mapcar #'(lambda (within-function) `(unadvise-within ,within-function ,@arguments)) list-within-functions))) (comment ;;not being used (defmacro unadvise-compiled (function-spec &rest arguments) `(unadvise-compiled-1 ',function-spec ,@(mapcar #'(lambda (argument) `',argument) arguments))) (deffun unadvise-compiled-1 (function-spec &rest arguments) (let* ((function (cond ((symbolp function-spec) function-spec) (t (selectq (first function-spec) (:within (second function-spec)))))) (old-definition (second (assq #-symbolics 'sys:interpreted-definition #+symbolics ':interpreted-definition (debugging-info function))))) (cond ((not (null old-definition)) (setf (fsymeval function) old-definition))) (lexpr-funcall #'si:unadvise-1 function-spec arguments))) (defmacro advise-compiled (&rest arguments) `(compiler-let ((compile-encapsulations-flag t)) (advise ,@arguments))) ) (cond ((fdefinedp 'si:break-internal) (forward-function-cell 'break-internal 'si:break-internal)) (t (forward-function-cell 'break-internal 'break))) (advise break-internal :around protect-state 0 (cond ((assq terminal-io *window-alist*) (unwind-protect (progn (eval-in-window terminal-io '(accept-environment-body)) :do-it) (eval-in-window terminal-io '(pop-environment-body 1)))) (t :do-it))) #-symbolics (advise-within-each (si:LISP-TOP-LEVEL1 break ;;si:EVAL-READ-OR-END-PROMPT-AND-READ ;;si:EVAL-READ-PROMPT-AND-READ ;;eh:FH-STREAM-BINDING-EVALER ) si:EVAL-ABORT-TRIVIAL-ERRORS :around prolog-top-level 0 (cond ((assq terminal-io *window-alist*) (eval-in-window terminal-io `(top-level-prove-and-show-results ',(first arglist)))) (t :do-it))) ;;the following redefinitions should simply be advise-with ... eval, however that facility is broken ;;in Symbolics release 4.5 #+(and symbolics (not CommonLisp)) (defun modified-lisp-top-level1 (si:TERMINAL-IO) si:(LET (* + - // ++ +++ ** *** THROW-FLAG READ-FLAG) (ERROR-RESTART-LOOP ((ERROR ABORT) "Lisp Top Level~@[ in ~A~]" (SEND TERMINAL-IO ':SEND-IF-HANDLES ':NAME)) (COND (THROW-FLAG (TERPRI) (PRINC "Back to Lisp Top Level") (COND ((SEND TERMINAL-IO ':OPERATION-HANDLED-P ':NAME) (PRINC " in ") (PRINC (SEND TERMINAL-IO ':NAME)))) (TERPRI))) (SETQ THROW-FLAG T) (TERPRI) (IF READ-FLAG (SETQ +++ ++ ++ + + -)) (SETQ READ-FLAG NIL) (SETQ - (READ-FOR-TOP-LEVEL)) (SETQ READ-FLAG T) (SETQ // (MULTIPLE-VALUE-LIST (cond ((assq terminal-io prolog:*window-alist*) (prolog:eval-in-window terminal-io `(prolog:top-level-prove-and-show-results ',-))) (t (EVAL -))))) (AND // (SETQ *** ** ** * * (CAR //))) (DOLIST (VALUE //) (TERPRI) (FUNCALL (OR PRIN1 #'PRIN1) VALUE)) (SETQ THROW-FLAG NIL)))) #+(and symbolics (not CommonLisp)) (setf #'si:lisp-top-level1 'modified-lisp-top-level1) ;;this is to avoid the redefinition warning #+(and symbolics CommonLisp) (defun modified-eval (&rest arguments) (cond ((assq terminal-io prolog:*window-alist*) (prolog:eval-in-window terminal-io `(prolog:top-level-prove-and-show-results ',(first arguments)))) (t (apply 'eval arguments)))) #+(and symbolics CommonLisp) (progn 'compile (setq si:*default-lisp-command-loop-eval-function* 'modified-eval ;release 5 si:*command-loop-eval-function* 'modified-eval ;release 6 ) (cond ((fdefinedp 'si:CP-OFF) (si:CP-OFF) (setq si:*READ-FORM-EDIT-TRIVIAL-ERRORS-P* nil))) ) #+symbolics ;Logically belongs to DB-SUPPORT. (advise readfile :around lm-prolog 0 (let (compile-p) :do-it)) #+(and symbolics (not CommonLisp)) (DEFUN modified-BREAK si:(&OPTIONAL "E TAG &EVAL (CONDITIONAL T) &AUX TEM SAVED-BUFFER (READ-FLAG T)) si: (IF CONDITIONAL (PROGW *BREAK-BINDINGS* ;; Deal with keyboard multiplexing in a way similar to the error-handler. ;; If we break in the scheduler, set CURRENT-PROCESS to NIL. ;; If this is not the scheduler process, make sure it has a run reason ;; in case we broke in the middle of code manipulating process data. ;; If INHIBIT-SCHEDULING-FLAG is set, turn it off and print a warning. (AND (BOUNDP 'SCHEDULER-STACK-GROUP) (EQ %CURRENT-STACK-GROUP SCHEDULER-STACK-GROUP) (SETQ CURRENT-PROCESS NIL)) (AND (NOT (NULL CURRENT-PROCESS)) (NULL (SEND CURRENT-PROCESS ':RUN-REASONS)) (SEND CURRENT-PROCESS ':RUN-REASON 'BREAK)) (COND (INHIBIT-SCHEDULING-FLAG (SEND STANDARD-OUTPUT ':FRESH-LINE) (SEND STANDARD-OUTPUT ':STRING-OUT "---> Turning off INHIBIT-SCHEDULING-FLAG, you may lose. <---") (SETQ INHIBIT-SCHEDULING-FLAG NIL))) (COND (RUBOUT-HANDLER (SETQ SAVED-BUFFER (SEND OLD-STANDARD-INPUT ':SEND-IF-HANDLES ':SAVE-RUBOUT-HANDLER-BUFFER)) (SETQ RUBOUT-HANDLER NIL))) (AND (LISTP TAG) (EQ (CAR TAG) 'QUOTE) (SETQ TAG (CADR TAG))) ;Some people are rightly confused. (SEND STANDARD-OUTPUT ':FRESH-LINE) (SEND STANDARD-OUTPUT ':STRING-OUT ">Breakpoint ") (PRINC TAG) (SEND STANDARD-OUTPUT ':LINE-OUT "; Resume to continue, Abort to quit.") (LET ((VALUE (DO () (NIL) ;Do forever (until explicit return) (TERPRI) LOOK-FOR-SPECIAL-KEYS ;; Read first character, even if it is a special key that ;; would normally be intercepted (synchronously). (LET ((TV:KBD-INTERCEPTED-CHARACTERS NIL)) (SETQ TEM (SEND STANDARD-INPUT ':TYI))) ;; Intercept characters even if otherwise disabled in program ;; broken out of. Also treat c-Z like ABORT for convenience ;; and for compatibility with the debugger. (AND (= TEM #/Z) (SETQ TEM #\ABORT)) (COND ((AND (BOUNDP 'TV:KBD-STANDARD-INTERCEPTED-CHARACTERS) (MEMQ TEM TV:KBD-STANDARD-INTERCEPTED-CHARACTERS)) (TV:KBD-INTERCEPT-CHARACTER TEM) (GO LOOK-FOR-SPECIAL-KEYS)) ((= TEM #\RESUME) (SEND STANDARD-OUTPUT ':LINE-OUT "[Resume]") (RETURN NIL)) ((= TEM #\ABORT) (SIGNAL 'ABORT)) ((= TEM #\HELP) (FORMAT T "~&You are typing at a BREAK read-eval-print-loop in ~A.~@ Type ~:C to return from this, ~:C to abort back to the ~ previous command level,~@ or ~:C to enter the debugger.~@ Type a Lisp form to be evaluated, or (RETURN ) ~ to return a value from BREAK.~%" TERMINAL-IO #\RESUME #\ABORT #\M-BREAK) (GO LOOK-FOR-SPECIAL-KEYS)) (T (SEND STANDARD-INPUT ':UNTYI TEM))) (MULTIPLE-VALUE (NIL TEM) (CATCH-ERROR-RESTART ((ERROR ABORT) "Return to Breakpoint ~A" TAG) (IF READ-FLAG (SETQ +++ ++ ++ + + -)) (SETQ READ-FLAG NIL) (MULTIPLE-VALUE (- TEM) (SEND STANDARD-INPUT ':RUBOUT-HANDLER '((:FULL-RUBOUT :FULL-RUBOUT)) #'READ-FOR-TOP-LEVEL)) (COND ((EQ TEM ':FULL-RUBOUT) (GO LOOK-FOR-SPECIAL-KEYS)) ((EQ - '$P) ;Altmode-P proceeds from BREAK (RETURN NIL)) ((AND (LISTP -) (EQ (CAR -) 'RETURN)) (RETURN (EVAL (CADR -))))) ;(RETURN form) proceeds (SETQ READ-FLAG T) (SETQ // (cond ((assq terminal-io prolog:*window-alist*) (prolog:eval-in-window terminal-io `(prolog:top-level-prove-and-show-results ',-)) nil) (t (MULTIPLE-VALUE-LIST (EVAL -))))) (AND // (SETQ *** ** ** * * (CAR //))) ;Save first value (DOLIST (VALUE //) (TERPRI) (FUNCALL (OR PRIN1 #'PRIN1) VALUE)))) (COND (TEM (SEND STANDARD-OUTPUT ':FRESH-LINE) (SEND STANDARD-OUTPUT ':STRING-OUT "Back to Breakpoint ") (PRINC TAG) (SEND STANDARD-OUTPUT ':LINE-OUT "; Resume to continue, Abort to quit.")))))) ;; Before returning, restore and redisplay rubout handler's buffer so user ;; gets what he sees, if we broke out of reading through the rubout handler. ;; If we weren't inside there, the rubout handler buffer is now empty because ;; we read from it, so leave it alone. (Used to :CLEAR-INPUT). (COND (SAVED-BUFFER (SEND OLD-STANDARD-INPUT ':RESTORE-RUBOUT-HANDLER-BUFFER SAVED-BUFFER))) VALUE)))) #+(and symbolics (not CommonLisp)) (setf #'break 'modified-break) #+symbolics (eval-when (compile eval) (or (fdefinedp 'si:ie-display-info) (sstatus feature symbolics-pre6))) (eval-when (compile eval load) (or (fdefinedp 'tv:rh-describe-arguments-check) (forward-function-cell 'tv:rh-describe-arguments-check 'si:ie-describe-arguments-check)) (or (fdefinedp 'tv:rh-defined-arguments-check) ;this may be a typo (forward-function-cell 'tv:rh-defined-arguments-check 'si:ie-defined-arguments-check)) (or (fdefinedp 'tv:rh-relevant-function) (forward-function-cell 'tv:rh-relevant-function 'si:ie-relevant-function)) (or (fdefinedp 'tv:rh-display-info) (forward-function-cell 'tv:rh-display-info 'si:ie-display-info))) #+(or symbolics CommonLisp) (defmacro define-rh-command (name character arguments &body body) `(tv:define-rh-command ,name (,character) #-(and symbolics CommonLisp) ,arguments ,@body)) #-(or symbolics CommonLisp) (defmacro define-rh-command (name character arguments &body body) `(tv:define-rh-command (,name ,character) ,arguments ,@body)) (define-rh-command speak-lisp #.*roman-I* (ignore) (eval-in-window terminal-io '(progn (setq *language* ':lisp) (display-prolog-label)))) (define-rh-command speak-prolog #.*roman-II* (ignore) (eval-in-window terminal-io '(progn (setq *language* ':prolog) (display-prolog-label)))) (define-rh-command speak-other #.*roman-III* (ignore) (eval-in-window terminal-io '(progn (setq *language* (selectq *language* (:prolog ':lisp) (:lisp ':prolog))) (display-prolog-label)))) ;;Returns nothing. (deffun possibilities-body () (cond ((null *possibilities*) (beep) (values)) (t (cond ((send *possibilities* ':next-answer) (send *possibilities* ':show-results) (let ((char (send standard-input ':tyi))) (cond ((= char #.*hand-down*) (possibilities-body)) (t (send standard-input ':untyi char) (values))))) (t (send *possibilities* ':show-results) (setq *possibilities* nil) (values)))))) (define-rh-command possibilities #.*hand-down* (ignore) ;;the upper case stuff here is courtesy of sys:ltop.lisp (system 93) (let ((SAVED-BUFFER) #-symbolics (SAVED-BUFFER-POSITION)) (AND (MEMQ ':SAVE-RUBOUT-HANDLER-BUFFER (FUNCALL STANDARD-INPUT ':WHICH-OPERATIONS)) (SETF (VALUES SAVED-BUFFER #-symbolics SAVED-BUFFER-POSITION) (FUNCALL STANDARD-INPUT ':SAVE-RUBOUT-HANDLER-BUFFER))) (eval-in-window terminal-io '(possibilities-body)) #+symbolics (format t "~&") ;; Before returning, restore and redisplay rubout handler's buffer so user ;; gets what he sees, if we broke out of reading through the rubout handler. ;; If we weren't inside there, the rubout handler buffer is now empty because ;; we read from it, so leave it alone. (Used to :CLEAR-INPUT). (COND (SAVED-BUFFER (*catch 'rubout-handler (FUNCALL STANDARD-INPUT ':RESTORE-RUBOUT-HANDLER-BUFFER SAVED-BUFFER #-symbolics SAVED-BUFFER-POSITION)))))) (define-rh-command accept-environment #.*hand-up* (ignore) (eval-in-window terminal-io '(accept-environment-body))) (define-rh-command pop-environment #.*control-hand-down* (ignore) (eval-in-window terminal-io `(pop-environment-body '1))) (defun accept-environment-body () (incf *prolog-level*) (push *mark* *mark-stack*) (setq *mark* (fill-pointer *trail-array*)) (push *possibilities* *possibilities-stack*) (setq *possibilities* ()) (display-prolog-label)) (defun pop-environment-body (n) (dotimes (i n) (cond ((null *mark-stack*) (beep)) (t (decf *prolog-level*) (setq *mark* (pop *mark-stack*)) ;(and possibilities* (send *possibilities* ':flush)) (setq *possibilities* (pop *possibilities-stack*))))) (display-prolog-label)) (defun display-prolog-label (&optional (window terminal-io)) (let ((string (selectq *language* (:prolog (format nil "Prolog level ~A" *prolog-level*)) (:lisp (send window ':send-if-handles ':name))))) (send window ':send-if-handles ':set-label string))) (define-rh-command help-for-prolog #.*super-help* (ignore) (tv:rh-display-info #-(and (not symbolics) CommonLisp) (ignore ignore #+symbolics-pre6 0) (princ *prolog-help*))) #-(and symbolics commonlisp) (defun talking-to-lisp () (cond zwei:((and (boundp '*interval*) *interval*) (and (not (memq 'prefer-prolog *mode-name-list*)) (not (memq 'ztop-mode-prolog *mode-name-list*)))) ((not (assq terminal-io *window-alist*))) (t (eq ':lisp (eval-in-window terminal-io '*language*))))) #+(and symbolics commonlisp) (defun talking-to-lisp () (cond zwei:((and (boundp '*interval*) *interval*) (and (not (memq (mode-of-flavor 'prefer-prolog) *mode-name-list*)) #-Commonlisp (not (memq (mode-of-flavor 'ztop-mode-prolog) *mode-name-list*)) )) ((not (assq terminal-io *window-alist*))) (t (eq ':lisp (eval-in-window terminal-io '*language*))))) (defun generally-defined (spec) (and (symbolp spec) (or (fdefinedp spec) #+symbolics (get spec 'tv:compiled-only-arglist) #-symbolics (get spec 'arglist) (and (not (talking-to-lisp)) (current-definition spec nil))))) #+(and symbolics CommonLisp) (setf #'tv:rh-defined-arguments-check 'generally-defined) (defun general-argument-list (symbol) (cond ((not (talking-to-lisp)) (multiple-value-bind (arg-list found-p) (predicate-argument-list symbol) (cond (found-p arg-list) (t (arglist symbol))))) (t (arglist symbol)))) (defun general-documentation (symbol) (or (cond ((not (talking-to-lisp)) (or (prolog:predicate-documentation symbol) (documentation symbol))) (t (documentation symbol #+(and (not symbolics) CommonLisp) 'function))) "No documentation found.")) ;;The following is a loss since we must keep pace with subsequent system releases. #+(and (not symbolics) (not CommonLisp)) (DEFINE-RH-COMMAND ARGUMENT-LIST #\CONTROL-SHIFT-A (IGNORE) tv: (LET ((BEGIN) (END) (SYMBOL)) (SETQ BEGIN (STRING-REVERSE-SEARCH-CHAR #/( RUBOUT-HANDLER-BUFFER (RH-TYPEIN-POINTER))) (OR BEGIN (SETQ BEGIN (STRING-SEARCH-CHAR #/( RUBOUT-HANDLER-BUFFER))) ;; If BEGIN is NIL at this point, the buffer is empty or contains only spaces. ;; END may be NIL if there are no spaces in the buffer, but NSUBSTRING interprets ;; NIL as meaning the end of the string. (COND ((NULL BEGIN) (FUNCALL-SELF ':BEEP)) (T (INCF BEGIN) (SETQ END (STRING-SEARCH-CHAR #\SPACE RUBOUT-HANDLER-BUFFER BEGIN)) (SETQ SYMBOL (READ-FROM-STRING RUBOUT-HANDLER-BUFFER NIL BEGIN END)) (IF (NULL SYMBOL) (FUNCALL-SELF ':BEEP) (RH-DISPLAY-INFO (IGNORE IGNORE SYMBOL) (IF (prolog:generally-defined symbol) (LET (;(AL (ARGLIST SYMBOL)) ;(PACKAGE PACKAGE) ) ;; Find an appropriate package to eliminate package prefixes of args. ;; (IF (LISTP AL) (DOLIST (ELT AL) (UNLESS (SYMBOLP ELT) (SETQ ELT (CAR ELT)) (UNLESS (SYMBOLP ELT) (SETQ ELT (CADR ELT)))) (IF (SYMBOLP ELT) (LET ((PKG (SYMBOL-PACKAGE ELT))) (AND (NEQ PKG SI:PKG-USER-PACKAGE) (NOT (SI:PKG-SUBPACKAGES PKG)) (RETURN (SETQ PACKAGE PKG))))))) ;;(IF (AND (SYMBOLP SYMBOL) (FBOUNDP SYMBOL)) ...) (FORMAT SELF "~S: ~S" SYMBOL (prolog:general-argument-list SYMBOL)) ;;(... (FORMAT SELF "Can't find a definition for ~S." SYMBOL)) ) (FORMAT SELF "Can't find a definition for ~S." SYMBOL)))))))) #+(and (not symbolics) (not CommonLisp)) (tv:add-rh-command 'com-argument-list (list #\hyper-control-a)) #+(and (not symbolics) CommonLisp) (DEFINE-RH-COMMAND RH-COM-ARGUMENT-LIST #\CONTROL-SHIFT-A (tv:IGNORE) tv: (LET ((FN (RH-GET-FUNCTION))) (IF (NULL FN) (FUNCALL-SELF ':BEEP) (RH-DISPLAY-INFO (IF (prolog:generally-defined FN) (ZWEI:PRINT-ARGLIST FN SELF) (FORMAT SELF "Can't find a definition for ~S." FN)))))) #+(and symbolics (not CommonLisp)) (DEFINE-RH-COMMAND DESCRIBE-ARGUMENTS #\CONTROL-SHIFT-A (tv:N) tv: (LET ((BEGIN) (END) (SYMBOL)) (SETQ BEGIN (STRING-REVERSE-SEARCH-CHAR #/( RUBOUT-HANDLER-BUFFER (RHB-TYPEIN-POINTER))) (SETQ BEGIN (IF BEGIN (1+ BEGIN) (STRING-SEARCH-NOT-CHAR #\SPACE RUBOUT-HANDLER-BUFFER))) ;; If BEGIN is NIL at this point, the buffer is empty or contains only spaces. ;; END may be NIL if there are no spaces in the buffer, but NSUBSTRING interprets ;; NIL as meaning the end of the string. (IF (NULL BEGIN) (RH-BARF)) (SETQ END (RH-SEARCH-CHAR #\SPACE BEGIN)) (SETQ SYMBOL (READ-FROM-STRING (NSUBSTRING RUBOUT-HANDLER-BUFFER BEGIN END) NIL)) (IF (NULL SYMBOL) (RH-BARF)) (RH-DISPLAY-INFO (IGNORE IGNORE N SYMBOL) (IF (prolog:generally-defined SYMBOL) (ZWEI:PRINT-ARGLIST SYMBOL SELF) (FORMAT SELF "Can't find a definition for ~S." SYMBOL)) T)) NIL) #+(and (not symbolics) (not CommonLisp)) (DEFINE-RH-COMMAND DOCUMENTATION #\CONTROL-SHIFT-D (tv:IGNORE) tv: (LET ((BEGIN) (END) (SYMBOL)) (SETQ BEGIN (STRING-REVERSE-SEARCH-CHAR #/( RUBOUT-HANDLER-BUFFER (RH-TYPEIN-POINTER))) (OR BEGIN (SETQ BEGIN (STRING-SEARCH-CHAR #/( RUBOUT-HANDLER-BUFFER))) ;; If BEGIN is NIL at this point, the buffer is empty or contains only spaces. ;; END may be NIL if there are no spaces in the buffer, but NSUBSTRING interprets ;; NIL as meaning the end of the string. (COND ((NULL BEGIN) (FUNCALL-SELF ':BEEP)) (T (INCF BEGIN) (SETQ END (STRING-SEARCH-CHAR #\SPACE RUBOUT-HANDLER-BUFFER BEGIN)) (SETQ SYMBOL (READ-FROM-STRING RUBOUT-HANDLER-BUFFER NIL BEGIN END)) (IF (NULL SYMBOL) (FUNCALL-SELF ':BEEP) (RH-DISPLAY-INFO (IGNORE IGNORE SYMBOL) (IF (prolog:generally-defined SYMBOL) (PROGN (LET (;(AL (ARGLIST SYMBOL)) ;(PACKAGE PACKAGE) ) ;; Find an appropriate package to eliminate package prefixes of args. ;; (WHEN (LISTP AL) (DOLIST (ELT AL) (UNLESS (SYMBOLP ELT) (SETQ ELT (CAR ELT)) (UNLESS (SYMBOLP ELT) (SETQ ELT (CADR ELT)))) (IF (SYMBOLP ELT) (LET ((PKG (SYMBOL-PACKAGE ELT))) (AND (NEQ PKG SI:PKG-USER-PACKAGE) (NOT (SI:PKG-SUBPACKAGES PKG)) (RETURN (SETQ PACKAGE PKG))))))) ;;(IF (AND (SYMBOLP SYMBOL) (FBOUNDP SYMBOL)) ...) (FORMAT SELF "~S: ~S" SYMBOL (prolog:general-argument-list SYMBOL)) ;;(... (FORMAT SELF "Can't find a definition for ~S." SYMBOL)) ) (WHEN (prolog:general-DOCUMENTATION SYMBOL) (TERPRI SELF) (SEND SELF ':STRING-OUT (prolog:general-DOCUMENTATION SYMBOL)))) (FORMAT SELF "Can't find a definition for ~S." SYMBOL)))))))) #+(and (not symbolics) (not CommonLisp)) (tv:add-rh-command 'com-documentation (list #\hyper-control-d)) #+(and (not symbolics) CommonLisp) (DEFINE-RH-COMMAND RH-COM-DOCUMENTATION #\CONTROL-SHIFT-D (tv:IGNORE) tv: (LET ((FN (RH-GET-FUNCTION))) (IF (NULL FN) (FUNCALL-SELF ':BEEP) (RH-DISPLAY-INFO (IF (prolog:generally-defined FN) (PROGN (ZWEI:PRINT-ARGLIST FN SELF) (WHEN (prolog:general-DOCUMENTATION FN) (TERPRI SELF) (SEND SELF ':STRING-OUT (prolog:general-DOCUMENTATION FN)))) (FORMAT SELF "Can't find a definition for ~S." FN)))))) #+(and symbolics (not CommonLisp)) (DEFINE-RH-COMMAND DOCUMENTATION #\CONTROL-SHIFT-D (tv:N) tv: (LET ((BEGIN) (END) (SYMBOL)) (SETQ BEGIN (STRING-REVERSE-SEARCH-CHAR #/( RUBOUT-HANDLER-BUFFER (RHB-TYPEIN-POINTER))) (SETQ BEGIN (IF BEGIN (1+ BEGIN) (STRING-SEARCH-NOT-CHAR #\SPACE RUBOUT-HANDLER-BUFFER))) ;; IF BEGIN IS NIL AT THIS POINT, THE BUFFER IS EMPTY OR CONTAINS ONLY SPACES. ;; END MAY BE NIL IF THERE ARE NO SPACES IN THE BUFFER, BUT NSUBSTRING INTERPRETS ;; NIL AS MEANING THE END OF THE STRING. (IF (NULL BEGIN) (RH-BARF)) (SETQ END (RH-SEARCH-CHAR #\SPACE BEGIN)) (SETQ SYMBOL (READ-FROM-STRING (NSUBSTRING RUBOUT-HANDLER-BUFFER BEGIN END) NIL)) (IF (NULL SYMBOL) (RH-BARF)) (RH-DISPLAY-INFO (IGNORE IGNORE N SYMBOL) (IF (prolog:generally-defined SYMBOL) (PROGN (ZWEI:PRINT-ARGLIST SYMBOL SELF) (TERPRI SELF) (SEND SELF ':STRING-OUT (prolog:general-documentation SYMBOL))) (FORMAT SELF "Can't find a definition for ~s." SYMBOL)) T)) NIL) #+(and symbolics CommonLisp) (define-rh-command documentation #\control-shift-d (ignore) tv: (rh-relevant-function #'(lambda (symbol stream) (zwei:print-arglist symbol stream) (terpri stream) (send stream ':string-out (prolog:general-documentation symbol)) t))) #+(and symbolics CommonLisp) tv: (progn 'compile (defun rh-describe-arguments-check-modified (symbol) (and (validate-function-spec symbol) (or (prolog:generally-defined symbol) (and (symbolp symbol) (get symbol 'compiled-only-arglist))))) (setf #'rh-describe-arguments-check #'rh-describe-arguments-check-modified)) #+symbolics zwei: (DEFUN prolog:modified-PRINT-ARGLIST (SYMBOL &OPTIONAL (STREAM *TYPEIN-WINDOW*)) (COND ((AND (BOUNDP '*TYPEIN-WINDOW*) (EQ STREAM *TYPEIN-WINDOW*)) (TYPEIN-LINE "") (FUNCALL STREAM ':TYPEOUT-STAYS))) (MULTIPLE-VALUE-BIND (ARGLIST RETURNS TYPE) (prolog:general-argument-list SYMBOL) (FORMAT STREAM "~S~@[ (~A)~]: " SYMBOL TYPE) (IF (OR (LISTP ARGLIST) (NULL ARGLIST)) (PRINT-ARGLIST-INTERNAL ARGLIST STREAM) (PRINC "??" STREAM)) (AND RETURNS (FORMAT STREAM "  ~:A" RETURNS)) (AND (SYMBOLP SYMBOL) (NOT (FBOUNDP SYMBOL)) (GETL SYMBOL '(SYS:COMPILED-ONLY-ARGLIST)) (PRINC " (in compiled code only)" STREAM)))) #+symbolics zwei: (setf #'print-arglist 'prolog:modified-print-arglist) ;;this is to avoid the redefinition warning ;;and here is LM-Prolog's DWIM facility (defflavor undefined-predicate-error (predicator worlds) (error) :gettable-instance-variables :initable-instance-variables) (defmethod (undefined-predicate-error :user-proceed-types) (proceed-types) ;;Force them to appear in preferred order. (list*-in-area *prolog-work-area* ':no-action ':new-value ':fail (cdddr proceed-types))) #-symbolics (progn 'compile (defmethod (undefined-predicate-error :case :proceed-asking-user :no-action) (continuation read-object-function) "Proceeds, using current definition if valid, or reading new predicator." (let ((def (find-and-cache-first-definition (definitions predicator) worlds))) (cond (def (send continuation ':no-action)) (t (send self ':proceed-asking-user ':new-value continuation read-object-function))))) (defmethod (undefined-predicate-error :case :proceed-asking-user :new-value) (continuation read-object-function) "Reads a new predicator to use instead." (send continuation ':new-value (send read-object-function ':read "~&Predicator to use instead: "))) (defmethod (undefined-predicate-error :case :proceed-asking-user :fail) (continuation ignore) "Make the call fail." (send continuation ':fail)) (defsignal undefined-predicate undefined-predicate-error (predicator worlds) "Signaled when an undefined predicate is invoked." ':predicator predicator ':worlds worlds) ) #+symbolics (progn 'compile (defmethod (undefined-predicate-error :report) (stream) (format stream "The predicate ~S is undefined." predicator)) (defmethod (undefined-predicate-error :case :proceed :no-action) () "Proceeds, using current definition if valid, or reading new predicator." (let ((def (find-and-cache-first-definition (definitions predicator) worlds))) (cond (def ':no-action) (t (send self ':proceed ':new-value))))) (defmethod (undefined-predicate-error :case :proceed :new-value) () "Reads a new predicator to use instead." (values ':new-value (prompt-and-read ':expression "~&Predicator to use instead: "))) (defmethod (undefined-predicate-error :case :proceed :fail) () "Make the call fail." ':fail) ) (defun undefined-predicate (predicator worlds) (declare (special predicator)) ;;for closure's sake (cond ((ask-about-each-world predicator (mapcar #'first (rest1 (definitions predicator))))) ((*catch 'package-map-tag (#-symbolics si:map-over-lookalike-symbols #+symbolics dbg:map-over-lookalike-symbols (string predicator) pkg-global-package #'ask-about-predicator-in-package predicator worlds))) ((and (fboundp predicator) (selectq (going-to-lisp-p "~%Type /"y/" to evaluate the form in Lisp, Type /"n/" to continue to search for definition, Or type /"g/" to evaluate the form in Lisp and go to Lisp." "~s is not defined in the current universe, but is a Lisp function, Run ~s in Lisp? " predicator predicator) (yes ;;return a dummy definition with funny prover (prolog-list (closure '(predicator) #'apply-predicator-as-function))) (no nil) (go-to-lisp ;;(send terminal-io ':force-kbd-input #.*roman-i*) (eval-in-window terminal-io '(progn (setq *language* ':lisp) (display-prolog-label))) (prolog-list (closure '(predicator) #'apply-predicator-as-function)))))) (t (multiple-value-bind (action new-name) #-symbolics (signal 'undefined-predicate "The predicate ~S is undefined." predicator worlds) #+symbolics (signal 'undefined-predicate-error ':predicator predicator ':worlds worlds) (selectq action (:no-action (find-and-cache-first-definition (definitions predicator) worlds predicator)) (:new-value (find-and-cache-first-definition (definitions new-name) worlds new-name)) (:fail (current-definition 'false))))))) (defvar going-to-lisp-help-string) (defun going-to-lisp-help (query-io &rest ignore) (format query-io going-to-lisp-help-string)) (defun going-to-lisp-p (going-to-lisp-help-string format-string &rest arguments) (lexpr-funcall #'fquery '(:choices (((yes "Yes") #/Y #/T #/y #/t #\SP) ((no "No") #/n #/N #\Rubout) ((go-to-lisp "Go to Lisp") #/g)) :help-function going-to-lisp-help) format-string arguments)) (defun atom-as-predication-prover (predication) (declare (special predication)) ;for the closure "Returns a closure which evaluates and prints PREDICATION and invokes cont." (selectq (going-to-lisp-p "~%Type /"y/" to evaluate the form in Lisp, Typing /"n/" gets an error, Or type /"g/" to evaluate the form in Lisp and go to Lisp." "The atom ~s given as a predication. Evaluate it? " predication) (yes (closure '(predication) #'print-eval-invoke)) (no (prolog-ferror ':atom-as-predication "~s, which is not a list, given as a predication." predication)) (go-to-lisp ;;(send terminal-io ':force-kbd-input #.*roman-i*) (eval-in-window terminal-io '(progn (setq *language* ':lisp) (display-prolog-label))) (closure '(predication) #'print-eval-invoke)))) (DEFUN PRINT-TOP-LEVEL (X) (TERPRI) (FUNCALL (OR PRIN1 #'PRIN1) X)) (defun print-eval-invoke (continuation) (declare (special predication)) ;;from closure (PRINT-TOP-LEVEL (GENERIC-EVAL predication)) (invoke continuation)) (defun apply-predicator-as-function (continuation &rest arguments) (declare (special predicator)) ;;from closure (let ((values (multiple-value-list (GENERIC-EVAL (cons predicator arguments))))) (mapc #'PRINT-TOP-LEVEL values)) (invoke continuation)) (defun ask-about-predicator-help (query-io &rest ignore) (format query-io "~%Type /"y/" to continue with new definition, Type /"n/" to continue to search for definition, Or type /"g/" to continue with new definition and go to the package")) (defun ask-about-predicator-in-package (symbol predicator worlds) (let ((definition (current-definition symbol nil worlds))) (and definition (selectq (fquery '(:choices (((yes "Yes") #/Y #/T #/y #/t #\SP) ((no "No") #/n #/N #\Rubout) ((go-to-package "Go to Package") #/g)) :help-function ask-abount-predicator-help) "~s is not defined in the current universe, but ~s is. Use ~s instead? " predicator symbol symbol) (yes (*throw 'package-map-tag definition)) (no nil) (go-to-package (pkg-goto (symbol-package symbol)) (*throw 'package-map-tag definition)))))) (defun ask-about-world-help (query-io &rest ignore) (format query-io "~%Type /"y/" to continue with new definition, Type /"n/" to continue to search for definition, Or type /"a/" to continue with new definition and add world to the universe.")) (deffun ask-about-each-world (predicator defined-in-worlds) (cond ((memq (first defined-in-worlds) *universe*) (cond ((y-or-n-p (prolog-string "Use definition of ~S in ~S? " predicator (first defined-in-worlds))) (definition-in-world predicator (first defined-in-worlds))) ((ask-about-each-world predicator (rest1 defined-in-worlds))))) (defined-in-worlds (selectq (fquery '(:choices (((yes "Yes") #/Y #/T #/y #/t #\SP) ((no "No") #/n #/N #\Rubout) ((add "Add World") #/a)) :help-function ask-about-world-help) "~s is not defined in the current universe, but is in ~s. Use definition in ~s? " predicator (first defined-in-worlds) (first defined-in-worlds)) (yes (definition-in-world predicator (first defined-in-worlds))) (no (ask-about-each-world predicator (rest1 defined-in-worlds))) (add (setq *universe* (cons (first defined-in-worlds) (delq (first defined-in-worlds) *universe*))) (definition-in-world predicator (first defined-in-worlds))))))) (defun going-to-prolog-help (query-io &rest ignore) (format query-io "~%Type /"y/" to let LM-Prolog prove the form, Type /"n/" to continue to search for definition, Or type /"g/" to let LM-Prolog prove the form and go to Prolog.")) (defun going-to-prolog-p (predicator) (declare (special predicator)) ;for the closure (selectq (fquery '(:choices (((yes "Yes") #/Y #/T #/y #/t #\SP) ((no "No") #/n #/N #\Rubout) ((go-to-prolog "Go to Prolog") #/g)) :help-function going-to-prolog-help) "~s is not a defined Lisp function, but is a Prolog predicate, Run ~s in Prolog? " predicator predicator) (yes (values ':store-new-value (closure '(predicator) #'query-internal))) (no nil) (go-to-prolog ;;(send terminal-io ':force-kbd-input #.*roman-ii*) (eval-in-window terminal-io '(progn (setq *language* ':prolog) (display-prolog-label))) (values ':store-new-value (closure '(predicator) #'query-internal))))) (defun query-internal (#-symbolics "e &rest arguments) (declare (special predicator)) #+symbolics (format t "~%[Sorry, I accidentally evaluated the arguments.]") (fmakunbound predicator) (query-once (prolog-cons predicator arguments)))