;;; -*- Mode: Lisp; Package: Zwei; Base: 10. ; Patch-file:T -*- ;;; (C) Copyright 1983,1984,1985, Uppsala University ;;Extensions to Zwei for LM-Prolog's sake (advise make-buffer-current :around update-prolog-defaults nil (let ((prolog:*add-world-when-loading* ':no)) :do-it ;;we want its value ;; (setq *defining-world-string* ;; (string (prolog:option-value ':world prolog:*default-options*))) )) #-(and (not CommonLisp) symbolics) (advise-within add-patch-interval insert-interval :around include-default-options 0 (let ((*file-default-options* (MULTIPLE-VALUE-BIND (VARS VALS) #+symbolics(fs:file-attribute-bindings *interval*) #-symbolics(send *interval* ':attribute-bindings) (PROGV VARS VALS prolog:*file-default-options*)))) (cond (*file-default-options* (let ((bp (INTERVAL-LAST-BP *PATCH-BUFFER*))) (insert bp (format nil "~%/(compiler-let ((prolog:*file-default-options* '~s))~%" *file-default-options*)) :do-it (insert bp "/)"))) (t :do-it)))) #+symbolics (defmethod (lisp-syntax-mixin :additional-attributes) () `((:BASE "Base" "~D") (:OPTIONS "Options" "~A") (:PACKAGE "Package" "~A") (:PATCH-FILE "Patch-File" "~A"))) (comment ;Make this private. (defcom com-macro-expand-region "Macroexpand the current region or definition, as if it were seen by the interpreter." () (com-reparse-attribute-list) (multiple-value-bind (vars vals) #+symbolics(fs:file-attribute-bindings *interval*) #-symbolics(send *interval* ':attribute-bindings) (progv vars vals (let (bp1 bp2) (COND ((WINDOW-MARK-P *WINDOW*) (SETQ BP1 (MARK) BP2 (POINT)) (OR (BP-< BP1 BP2) (PSETQ BP1 BP2 BP2 BP1))) ((setq bp1 (DEFUN-INTERVAL (BEG-LINE (POINT)) 1 NIL NIL)) (SETQ BP2 (INTERVAL-LAST-BP BP1) BP1 (INTERVAL-FIRST-BP BP1))) (T (BARF "Unbalanced parentheses"))) (LET ((STREAM (INTERVAL-STREAM bp1 bp2 t))) (do ((FORM (READ STREAM '*EOF*) (READ STREAM '*EOF*))) ((EQ FORM '*EOF*)) (grind-top-level (MACROEXPAND FORM))))))) DIS-NONE) (defcom com-macro-expand-region-compiled "Macroexpand the current region or definition, as if it were seen by the compiler." () (let ((prolog:compile-p t)) (com-macro-expand-region)))) (advise com-macro-expand-expression :around bind-attributes 0 (multiple-value-bind (vars vals) #+symbolics(fs:file-attribute-bindings *interval*) #-symbolics(send *interval* ':attribute-bindings) (progv vars vals :do-it))) (advise com-macro-expand-expression-all :around bind-attributes 0 (multiple-value-bind (vars vals) #+symbolics(fs:file-attribute-bindings *interval*) #-symbolics(send *interval* ':attribute-bindings) (progv vars vals :do-it))) #-symbolics prolog: (advise-within zwei:com-documentation documentation :around prolog-top-level 0 (multiple-value-bind (documentation defined-p) (predicate-documentation (first arglist)) (cond ((and defined-p (NOT (talking-to-lisp))) documentation) (t :do-it)))) #-(and (not CommonLisp) symbolics) prolog: (advise-within-each (#-symbolics zwei:com-quick-documentation zwei:com-brief-documentation zwei:com-long-documentation) si:function-documentation :around prolog-top-level 0 (multiple-value-bind (documentation defined-p) (predicate-documentation (first arglist)) (cond ((and defined-p (NOT (talking-to-lisp))) documentation) (t :do-it)))) prolog: (advise zwei:relevant-function-name :around prolog-top-level 0 (cond ((talking-to-lisp) :do-it) ((fourth arglist) :do-it) (t (zwei:relevant-function-name (first arglist) (second arglist) (third arglist) (or (fourth arglist) t))))) #-(and (not CommonLisp) symbolics) prolog: (advise-within-each (zwei:quick-arglist zwei:print-arglist) arglist :around prolog-top-level 0 (general-argument-list (first arglist))) #-(and (not CommonLisp) symbolics) prolog: (advise-within-each (zwei:quick-arglist zwei:com-long-documentation) fdefinedp :around prolog-top-level 0 (generally-defined (first arglist))) #+(and (not CommonLisp) symbolics) (DEFCOM COM-BRIEF-DOCUMENTATION "Displays brief documentation for the specified Lisp function or LM-Prolog predicate. By default, it displays documentation for the current function. With a numeric argument, it prompts for a function name, which you can either type in or select with the mouse. It displays the first line from the summary paragraph in the echo area. " () (LET* ((DEF (RELEVANT-FUNCTION-NAME (POINT))) (NAME (IF *NUMERIC-ARG-P* (READ-FUNCTION-SPEC "Brief Document" DEF) DEF)) (DOC (prolog:general-documentation NAME))) (COND ((NULL DOC) (TYPEIN-LINE "~S is not documented" NAME)) (T (TYPEIN-LINE "~S: ~A" NAME (NSUBSTRING DOC 0 (STRING-SEARCH-CHAR #\CR DOC)))))) DIS-NONE) #+(and (not CommonLisp) symbolics) (DEFCOM COM-LONG-DOCUMENTATION "Displays the summary documentation for the specified function. It prompts for a function name, which you can either type in or select with the mouse. The default is the current function. " () (modified-TYPEOUT-LONG-DOCUMENTATION (READ-FUNCTION-SPEC "Document" (RELEVANT-FUNCTION-NAME (POINT)))) DIS-NONE) #+(and (not CommonLisp) symbolics) (DEFUN modified-TYPEOUT-LONG-DOCUMENTATION (NAME) (LET ((DOC (prolog:general-documentation NAME))) (COND ((NULL DOC) (TYPEIN-LINE "~S is not documented" NAME)) (T (PRINT-ARGLIST NAME) (FORMAT T "~%~A" DOC))))) (DEFCOM COM-SET-OPTIONS "Change LM-Prolog's default options associated with this buffer or file. Applies only to this buffer, and overrides what the attribute list says. Queries you for whether to change the attribute list in the text as well. The new value is read in the minibuffer." () (let* ((package (symbol-package ':keyboard)) (options (TYPEIN-LINE-READ "Set options:"))) (prolog:warn-if-unrecognized-option options "these options") ;7.12 #+symbolics (SEND *INTERVAL* ':PUTPROP OPTIONS ':OPTIONS) #+symbolics (SET-ATTRIBUTE-INTERNAL ':OPTIONS "Options" (FORMAT NIL "~S" OPTIONS) OPTIONS) #-symbolics (SEND *INTERVAL* ':SET-ATTRIBUTE ':options options ':QUERY) ) #+symbolics DIS-TEXT #-symbolics DIS-NONE) (SET-COMTAB *STANDARD-COMTAB* () '(("Set Options" . com-set-options))) (DEFMINOR COM-Prefer-Lisp Prefer-Lisp "" 1 "Makes c-s-A and c-s-D apply to Lisp functions (the default)." ()) (DEFMINOR COM-Prefer-Prolog Prefer-Prolog "" 1 "Makes c-s-A and c-s-D apply to Prolog predicates." ()) (defcom com-prefer-lisp "Makes c-s-A and c-s-D prefer Lisp (the default)." () (turn-off-mode 'prefer-prolog) (turn-on-mode 'prefer-lisp) dis-none) (defcom com-prefer-prolog "Makes c-s-A and c-s-D prefer Prolog." () (turn-off-mode 'prefer-lisp) (turn-on-mode 'prefer-prolog) dis-none) (defcom com-prefer-other "Makes c-s-A and c-s-D prefer the other language." () (cond ((prolog:talking-to-lisp) (com-prefer-prolog)) (t (com-prefer-lisp)))) (SET-COMTAB *STANDARD-COMTAB* '(#.prolog:*roman-i* com-prefer-Lisp #.prolog:*roman-ii* com-prefer-Prolog #.prolog:*roman-iii* com-prefer-Other ; #\Control-Shift-M com-macro-expand-region ; #\Meta-Shift-M com-macro-expand-region-compiled ; #-CommonLisp #\Hyper-Control-M #-CommonLisp com-macro-expand-region ; #-CommonLisp #\Hyper-Meta-M #-CommonLisp com-macro-expand-region-compiled ) '(("Prefer Lisp" . com-prefer-lisp) ("Prefer Prolog" . com-prefer-prolog) ("Prefer Other" . com-prefer-other))) ;; The following are for Ztop's sake --- courtesy SYS: ZWEI; STREAM #-CommonLisp (progn 'compile (defprop *current-command-type* t mode-settable-p) (defprop *prolog-form* t mode-settable-p) (defvar *prolog-level* "0") (defvar *prolog-form* () "Thing to be evaluated by the Ztop stack group when in Prolog mode.") (DEFMETHOD (ZTOP-STREAM-MIXIN :STREAM-RUBOUT-HANDLER) () ;; If everything has been typed out correctly, update the window datastructure #+symbolics (AND (< (WINDOW-REDISPLAY-DEGREE *WINDOW*) DIS-TEXT) (FAKE-OUT-TOP-LINE *WINDOW* *INTERVAL*)) #-symbolics (AND (< (WINDOW-REDISPLAY-DEGREE *STREAM-SHEET*) DIS-TEXT) (FAKE-OUT-TOP-LINE *STREAM-SHEET* (WINDOW-INTERVAL *STREAM-SHEET*))) (SETQ *ZTOP-SG* SYS:%CURRENT-STACK-GROUP) (WITH-BP (OLD-STREAM-BP *STREAM-BP* ':NORMAL) (let ((msg (FUNCALL *ZMACS-SG*))) (cond ((and (listp msg) (memq (car msg) 'prolog:(possibilities-body pop-environment-body accept-environment-body setq))) (prolog:eval-in-window terminal-io msg) (cond ((eq (car msg) 'prolog:possibilities-body) ;;Unlike behavior in Lisp listeners, typing Hand-Down will forget typein ;;so far. Fix it some day maybe. (funcall-self ':fresh-line) (move-bp *stream-start-bp* *stream-bp*) (move-bp old-stream-bp *stream-bp*)))) (msg (*THROW 'RUBOUT-HANDLER T)))) (MOVE-BP *STREAM-BP* OLD-STREAM-BP)) (FUNCALL-SELF ':ANY-TYI)) (DEFMETHOD (ZTOP-STREAM-MIXIN :COMMAND-HOOK) (TYPE &AUX (OLD-STATE *RUBOUT-HANDLER-STATE*)) (AND (ASSQ ':FULL-RUBOUT *RUBOUT-HANDLER-ARGS*) (BP-= *STREAM-START-BP* *STREAM-BP*) (SETQ OLD-STATE ':EDITING TYPE ':FULL-RUBOUT)) (SETQ *RUBOUT-HANDLER-STATE* (COND ((AND (BP-= *STREAM-BP* (INTERVAL-LAST-BP #+symbolics *INTERVAL* #-symbolics (WINDOW-INTERVAL *STREAM-SHEET*))) #-symbolics (OR (NOT *STREAM-ACTIVATION-NEEDED*) (memq TYPE '(ACTIVATE-ZTOP prolog))) (MEMQ TYPE '(SELF-INSERT INSERT-CR ACTIVATE-ZTOP prolog ZTOP-MODE :FULL-RUBOUT))) ':NORMAL) #+symbolics ((EQ *RUBOUT-HANDLER-STATE* ':VIRGIN) ':VIRGIN) (T ':EDITING))) (COND ((EQ *RUBOUT-HANDLER-STATE* ':NORMAL) (AND (NEQ OLD-STATE ':NORMAL) ;If we were editing (MOVE-BP *STREAM-BP* *STREAM-START-BP*)) (SETQ *ZMACS-SG* SYS:%CURRENT-STACK-GROUP) (FUNCALL CURRENT-PROCESS ':ADD-COROUTINE-STACK-GROUP *ZTOP-SG*) (LET ((NORMAL-EXIT-P NIL)) (UNWIND-PROTECT (PROGN (FUNCALL *ZTOP-SG* (cond ((eq type 'prolog) *prolog-form*) ((EQ OLD-STATE ':EDITING)))) (SETQ NORMAL-EXIT-P T)) (OR NORMAL-EXIT-P #+symbolics (LET (#-3600 (DBG:*ERROR-SG* *ZTOP-SG*)) (DBG:THROW-FROM-ERROR-ENVIRONMENT 'ZTOP-TOP-LEVEL '(T T))) #-symbolics (EH:SG-THROW *ZTOP-SG* 'ZTOP-TOP-LEVEL T)))) (SETQ PACKAGE (SYMEVAL-IN-STACK-GROUP '*PACKAGE* *ZTOP-SG*)) (AND (NEQ OLD-STATE ':NORMAL) (MUST-REDISPLAY #+symbolics *WINDOW* #-symbolics *STREAM-SHEET* DIS-BPS)) #+symbolics (COND (TV:UNRCHF (FUNCALL STANDARD-INPUT ':UNTYI TV:UNRCHF) (SETQ TV:UNRCHF NIL)))) (T (SETQ *STREAM-ACTIVATION-NEEDED* (AND #-symbolics *ZTOP-REQUIRE-ACTIVATION* (OR (EQ *RUBOUT-HANDLER-STATE* ':EDITING) (NOT (BP-= *STREAM-START-BP* (INTERVAL-LAST-BP #+symbolics *INTERVAL* #-symbolics (WINDOW-INTERVAL *STREAM-SHEET*))))))))) #-symbolics (SETQ *ZTOP-ACTIVATION-NEEDED* *STREAM-ACTIVATION-NEEDED*) #-symbolics (SETQ *ZTOP-EDITING* (AND (NOT *ZTOP-ACTIVATION-NEEDED*) (EQ *RUBOUT-HANDLER-STATE* ':EDITING))) #-symbolics (SETQ *ZTOP-READING-INPUT* (AND (NOT *ZTOP-ACTIVATION-NEEDED*) (NOT *ZTOP-EDITING*)))) (DEFMINOR COM-Ztop-Talk-To-Lisp ZTOP-MODE-Lisp "talking to Lisp" 1 "If in ZTOP talk to Lisp (the default)." () (setq *current-command-type* 'prolog) (setq *prolog-form* '(setq prolog:*language* ':Lisp))) (defcom com-ztop-talk-to-lisp "Makes a ZTOP talk to Lisp (the default)." () (cond ((eq *major-mode* 'ztop-mode) (turn-off-mode 'ztop-mode-prolog) (turn-on-mode 'ztop-mode-lisp)) (t (barf "Command not applicable in this context."))) dis-none) (DEFMINOR COM-Ztop-Talk-To-Prolog ZTOP-MODE-Prolog "talking to Prolog" 1 "If in ZTOP talk to Prolog." () (setq *mode-line-list* (append *mode-line-list* '((*prolog-level* " Prolog level: " *prolog-level*)))) (setq *current-command-type* 'prolog) (setq *prolog-form* '(setq prolog:*language* ':Prolog))) (defcom com-ztop-talk-to-prolog "Makes a ZTOP talk to Prolog." () (cond ((eq *major-mode* 'ztop-mode) (turn-off-mode 'ztop-mode-lisp) (turn-on-mode 'ztop-mode-prolog)) (t (barf "Command not applicable in this context."))) dis-none) (defcom com-ztop-talk-to-other "Makes a ZTOP talk to the other language." () (cond ((prolog:talking-to-lisp) (com-ztop-talk-to-prolog)) (t (com-ztop-talk-to-lisp)))) (defmethod (ztop-stream-mixin :set-label) (string) ;;came in just handy (cond ((string-equal "Prolog level " string 0 0 13. 13.) (setq *prolog-level* (nsubstring string 13.)) ;(redisplay-mode-line) ;;not in this context )) t) (defcom com-possibilities "Tries to find more possibilities of the most recently typed LM-Prolog query." (n) (setq *current-command-type* 'prolog *prolog-form* `(prolog:possibilities-body)) dis-text) (defcom com-accept-environment "`Accepts' the LM-Prolog environment. You may `reject' it again by Meta-X Pop Environment." () (setq *current-command-type* 'prolog *prolog-form* `(prolog:accept-environment-body)) dis-none) (defcom com-pop-environment "`Rejects' the LM-Prolog environment." (ignore) (setq *current-command-type* 'prolog *prolog-form* `(prolog:pop-environment-body ',zwei:*numeric-arg*)) dis-none) ;;Dirty... (push '(SET-COMTAB *mode-COMTAB* '(#.prolog:*roman-i* com-ztop-talk-to-Lisp #.prolog:*roman-ii* com-ztop-talk-to-Prolog #.prolog:*roman-iii* com-ztop-talk-to-other #.prolog:*hand-up* com-accept-environment #.prolog:*hand-down* com-possibilities #.prolog:*control-hand-down* com-pop-environment) '(("Talk to Prolog" . com-ztop-talk-to-prolog) ("Talk to Lisp" . com-ztop-talk-to-lisp) ("Talk to Other" . com-ztop-talk-to-other))) (get 'ztop-mode 'mode)) )