home *** CD-ROM | disk | FTP | other *** search
/ Enter 2004 January / enter-2004-01.iso / files / maxima-5.9.0.exe / {app} / share / maxima / 5.9.0 / src / macsys.lisp < prev    next >
Encoding:
Text File  |  2003-02-09  |  15.5 KB  |  490 lines
  1. ;;; -*-  Mode: Lisp; Package: Maxima; Syntax: Common-Lisp; Base: 10 -*- ;;;;
  2. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  3. ;;;     The data in this file contains enhancments.                    ;;;;;
  4. ;;;                                                                    ;;;;;
  5. ;;;  Copyright (c) 1984,1987 by William Schelter,University of Texas   ;;;;;
  6. ;;;     All rights reserved                                            ;;;;;
  7. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  8. ;;;
  9. ;;; ** (c) Copyright 1981 Massachusetts Institute of Technology **
  10. ;;;
  11. ;;; SYSTEM: The ``New'' Macsyma System Stuff
  12. ;;;
  13. ;;; *** NOTE *** this file uses common-lisp read syntax.
  14.  
  15. (in-package "MAXIMA")
  16. (macsyma-module system)
  17.  
  18.  
  19. (eval-when (eval compile load) (sstatus feature maxii))
  20.  
  21. ;;; Standard Kinds of Input Prompts
  22.  
  23. (DEFUN MAIN-PROMPT ()
  24.   ;; instead off using this STRIPDOLLAR hackery, the
  25.   ;; MREAD function should call MFORMAT to print the prompt,
  26.   ;; and take a format string and format arguments.
  27.   ;; Even easier and more general is for MREAD to take
  28.   ;; a FUNARG as the prompt. -gjc
  29.   (FORMAT () "(~A~D) " (STRIPDOLLAR $INCHAR) $LINENUM))
  30.  
  31. (DEFUN BREAK-PROMPT ()
  32.   (declare (special $prompt))
  33.   (STRIPDOLLAR $PROMPT))
  34.  
  35.  
  36.  
  37. ;; there is absoletely no need to catch errors here, because
  38. ;; they are caught by the macsyma-listener window process on
  39. ;; the lisp machine, or by setting the single toplevel process in Maclisp. -gjc
  40.  
  41. (defmacro toplevel-macsyma-eval (x) `(meval* ,x))
  42.  
  43. (defmvar $_ '$_ "last thing read in, cooresponds to lisp +")
  44. ;Also defined in JPG;SUPRV
  45. #-CL (defmvar $% '$% "last thing printed out, cooresponds to lisp *")
  46. (defmvar $__ '$__ "thing read in which will be evaluated, cooresponds to -")
  47.  
  48. (declare-top (special *mread-prompt*  $file_search_demo))
  49.  
  50. (defvar accumulated-time 0.0)
  51. #-cl
  52. (defun fixnum-char-upcase (x) (char-upcase x))
  53. ;#-ti
  54. ;(defun get-internal-real-time () (time:microsecond-time))
  55. ;#-ti
  56. ;(defun get-internal-run-time ()  (* 1000 (send current-process :cpu-time)) )
  57. ;(defvar internal-time-units-per-second  1000000)
  58.  
  59. #+lispm
  60. (defun used-area ( &optional (area working-storage-area ))
  61.   (multiple-value-bind (nil used)(si:room-get-area-length-used area)
  62.     used))
  63.  
  64. #+cmu
  65. (defun used-area (&optional unused)
  66.   (declare (ignore unused))
  67.   (ext:get-bytes-consed))
  68.  
  69. #+clisp
  70. (defun used-area (&optional unused)
  71.   (declare (ignore unused))
  72.   (multiple-value-bind (real1 real2 run1 run2 gc1 gc2 space1 space2 gccount)
  73.       (sys::%%time)
  74.     (declare (ignore real1 real2 run1 run2 gc1 gc2 gccount))
  75.     (dpb space1 (byte 24 24) space2)))
  76.  
  77. #-(or lispm cmu clisp)
  78. (defun used-area (&optional unused)
  79.   (declare (ignore unused))
  80.   0)
  81.  
  82. (DEFUN CONTINUE (&OPTIONAL (input-stream *standard-input*)
  83.                BATCH-OR-DEMO-FLAG)
  84.  (if (eql BATCH-OR-DEMO-FLAG :demo)
  85.      (format t "~% At the _ prompt, type ';' followed by enter to get next demo"))
  86.  (catch 'abort-demo
  87.   (DO ((R)
  88.        (time-before)
  89.        (time-after)
  90.        (time-used)
  91.        (EOF (LIST NIL))
  92.        (etime-before)
  93.        (etime-after)
  94.        (area-before)
  95.        (area-after)
  96.        (etime-used)
  97.        (c-tag)
  98.        (d-tag))
  99.       (NIL)
  100.     (when (not (checklabel $inchar))
  101.       (setq $linenum (f1+ $linenum)))
  102.     #+akcl(si::reset-stack-limits)
  103.     (setq c-tag (makelabel $inchar))
  104.     (LET ((*MREAD-PROMPT* (if batch-or-demo-flag nil (MAIN-PROMPT)))
  105.       (eof-count 0))
  106.     (tagbody
  107.      top
  108.      (SETQ R      (dbm-read input-stream nil eof))
  109.      ; This is something of a hack. If we are running in a server mode
  110.      ; (which we determine by checking *socket-connection*) and we get
  111.      ; an eof on an input-stream that is not *standard-input*, switch
  112.      ; the input stream to *standard-input*.
  113.      ; There should probably be a better scheme for server mode.
  114.      ; jfa 10/09/2002.
  115.      (if (and
  116.       (eq r eof)
  117.        (not (eq input-stream *standard-input*))
  118.        (boundp '*socket-connection*))
  119.      (progn
  120.            (setq input-stream *standard-input*)
  121.            (setq *mread-prompt* nil)
  122.            (setq r (dbm-read input-stream nil eof))))
  123.  
  124.      (cond ((and (eq r eof) (boundp '*socket-connection*)
  125.          (eq input-stream *socket-connection*))
  126.         (cond ((>=  (setq eof-count (+ 1 eof-count)) 10)
  127.            (print "exiting on eof")
  128.            ($quit))
  129.           (t (go top)))))
  130.          
  131.      (cond ((and (consp r) (keywordp (car r)))
  132.         (break-call (car r) (cdr r) 'break-command)
  133.           (go top)))
  134.           
  135.      )
  136.     )
  137.     
  138.  
  139.     (cond (#.writefilep ;write out the c line to the dribble file
  140.         (let ( (#.ttyoff t) smart-tty  $linedisp)
  141.           (displa `((mlable) , c-tag , $__)))))
  142.     (IF (EQ R EOF) (RETURN '$DONE))
  143.     (fresh-line *standard-output*)
  144.     #+lispm (SEND *standard-output* :SEND-IF-HANDLES ':FORCE-OUTPUT)
  145.     (SETQ $__ (CADDR R))
  146.     (SET  C-TAG $__)
  147.     (cond (batch-or-demo-flag
  148.        (displa `((mlable) ,c-tag , $__))))
  149.     (setq time-before (get-internal-run-time)
  150.       etime-before (get-internal-real-time))
  151.     (setq area-before (used-area))
  152.     (SETQ $% (TOPLEVEL-MACSYMA-EVAL $__))
  153.     (setq etime-after (get-internal-real-time)
  154.       time-after (get-internal-run-time))
  155.     (setq area-after (used-area))
  156.     (setq time-used (quotient (float (difference time-after time-before))
  157.                   internal-time-units-per-second)
  158.       etime-used (quotient (float (difference etime-after etime-before))
  159.                    internal-time-units-per-second))
  160.     (setq accumulated-time (plus accumulated-time time-used))
  161.     (SET (setq D-TAG (makelabel $outchar)) $%)
  162.     (SETQ $_ $__)
  163.     (when $showtime
  164.       #+NIL (format t "~&Evaluation took ~$ seconds (~$ elapsed)."
  165.             time-used etime-used)
  166.       #-(or NIL cl) (mtell "Evaluation took ~S seconds (~S elapsed)."
  167.                time-used etime-used)
  168.       (format t "~&Evaluation took ~$ seconds (~$ elapsed)"
  169.                    time-used etime-used )
  170.       #+lispm (format t "using ~A words." (f-  area-after area-before))
  171.       #+(or cmu clisp)
  172.       (let ((total-bytes (- area-after area-before)))
  173.         (cond ((> total-bytes 1024)
  174.            (format t " using ~,3F KB." (/ total-bytes 1024.0))
  175.            )
  176.           ((> total-bytes (* 1024 1024))
  177.            (format t " using ~,3F MB." (/ total-bytes (* 1024.0 1024.0)))
  178.            )
  179.           (t
  180.            (format t " using ~:D bytes." total-bytes))))
  181.  
  182.       )
  183.     (UNLESS $NOLABELS
  184.              (PUTPROP d-tag
  185.                   (cons time-used  0)
  186.                   'TIME))
  187.     (fresh-line *standard-output*)
  188.     #+never(let ((tem (read-char-no-hang)))
  189.       (or (eql tem #\newline) (and tem (unread-char tem))))
  190.     (IF (EQ (CAAR R) 'DISPLAYINPUT)
  191.     (DISPLA `((MLABLE) ,D-TAG ,$%)))
  192.     (when (eq batch-or-demo-flag ':demo)
  193.       (mtell "~&_")
  194.       (let (quitting)      
  195.        (do ((char)) (nil)
  196.          ;;those are common lisp characters you'r reading here
  197.         (case
  198.          (setq char (read-char *terminal-io*))
  199.          ((#\page) (unless (cursorpos 'c input-stream) (terpri *standard-output*))
  200.           (princ "_" *standard-output*))
  201.          ((#\?) (mtell "  Pausing.  Type a ';' and Enter to continue demo.~%_"))
  202.          ((#\space #\; #\n #\e #\x #\t))
  203.          ((#\newline )
  204.           (if quitting (throw 'abort-demo nil) (return nil))) 
  205.          (t (setq quitting t)
  206.         )))))
  207.     ;; This is sort of a kludge -- eat newlines and blanks so that they don't echo
  208.     (AND BATCH-OR-DEMO-FLAG
  209.      #+lispm
  210.      (send input-stream :operation-handled-p :read-char-no-echo)
  211.      #+lispm
  212.      (send input-stream :operation-handled-p :unread-char-no-echo)
  213.      (do ((char)) (())
  214.        (setq char (read-char input-stream nil #+cl nil)) 
  215.  
  216. ;;;; INSERTED BY MASAMI 
  217.            (when (null char) 
  218.              (throw 'MACSYMA-QUIT NIL)) 
  219. ;;;; END INSERT 
  220.  
  221.        (unless (zl-MEMBER char '(#\space #\newline #\return #\tab))
  222.            (unread-char char input-stream)  
  223.          (return nil))))))) 
  224.  
  225.  
  226. (DEFUN $BREAK (&REST ARG-LIST)
  227.   (PROG1 (apply #'$PRINT ARG-LIST)
  228.      (MBREAK-LOOP)))
  229.  
  230.  
  231.  
  232. (DEFUN MBREAK-LOOP ()
  233.   (LET ((*standard-input* #+nil (make-synonym-stream '*terminal-io*)
  234.             #-nil *debug-io*)
  235.     (*standard-output* *debug-io*))
  236.     (CATCH 'BREAK-EXIT
  237.       (format t "~%Entering a Macsyma break point. Type EXIT; to resume")
  238.       (DO ((R)) (NIL)
  239.     (fresh-line)
  240.     (SETQ R (CADDR (LET ((*MREAD-PROMPT* (BREAK-PROMPT)))
  241.              (MREAD *standard-input*))))
  242.     (CASE R
  243.       (($EXIT) (THROW 'BREAK-EXIT T))
  244.       (T (ERRSET (DISPLA (MEVAL R)) T)))))))
  245.  
  246. (defun merrbreak (&optional arg)
  247.   (format *debug-io* "~%Merrbreak:~A" arg)
  248.   (mbreak-loop))
  249.  
  250. #-cl
  251. (DEFUN RETRIEVE (MSG FLAG &AUX (PRINT? NIL))
  252.   (DECLARE (SPECIAL MSG FLAG PRINT?))
  253.   (OR (EQ FLAG 'NOPRINT) (SETQ PRINT? T))
  254.   (MREAD-TERMINAL
  255.     (CLOSURE '(MSG FLAG)
  256.        #'(LAMBDA (STREAM CHAR) STREAM CHAR
  257.        (COND ((NOT PRINT?) (SETQ PRINT? T))
  258.          ((NULL MSG))
  259.          ((ATOM MSG) (PRINC MSG) (MTERPRI))
  260.          ((EQ FLAG T) (MAPC #'PRINC (CDR MSG)) (MTERPRI))
  261.          (T (DISPLA MSG) (MTERPRI)))))))
  262. #+cl
  263. (DEFUN RETRIEVE (MSG FLAG &AUX (PRINT? NIL))
  264.   (DECLARE (SPECIAL MSG FLAG PRINT?))
  265.   (OR (EQ FLAG 'NOPRINT) (SETQ PRINT? T))
  266.   (COND ((NOT PRINT?) (SETQ PRINT? T))
  267.     ((NULL MSG))
  268.     ((ATOM MSG) (PRINC MSG) (MTERPRI))
  269.     ((EQ FLAG T) (MAPC #'PRINC (CDR MSG)) (MTERPRI))
  270.     (T (DISPLA MSG) (MTERPRI)))
  271.   (mread-noprompt *query-io* nil))
  272.  
  273.  
  274. (DEFMFUN $READ (&REST L)
  275.   (MEVAL (APPLY #'$READONLY L)))
  276.  
  277. (DEFMFUN $READONLY (&REST L)
  278.   (let ((*mread-prompt*
  279.       (if l (string-right-trim '(#\n)
  280.                    (with-output-to-string (*standard-output*)
  281.                        (apply '$print l))) "")))
  282.   (third (mread *query-io*))))
  283.  
  284. #-cl
  285. (DEFUN MREAD-TERMINAL (PROMPT)
  286.   (prog1 (let (#+NIL (si:*ttyscan-dispatch-table *macsyma-ttyscan-operators*))
  287.         (CADDR (send *terminal-io* ':RUBOUT-HANDLER
  288.              `((:PROMPT ,PROMPT) #+NIL (:reprompt ,prompt))
  289.              #'MREAD-RAW *terminal-io*)))
  290.      (fresh-line *terminal-io*)))
  291.  
  292.  
  293.  
  294. (DEFUN MAKE-INPUT-STREAM (X Y) Y ;ignore
  295.   X)
  296.  
  297. (DEFUN BATCH (FILENAME &OPTIONAL DEMO-P
  298.           &AUX (orig filename )
  299.           list
  300.           FILE-OBJ (accumulated-time 0.0) (abortp t))
  301.   (setq list (if demo-p '$file_search_demo '$file_search_maxima))
  302.   (setq filename ($file_search filename (symbol-value list)))
  303.   (or filename (merror "Could not find ~M in ~M: ~M"
  304.                orig list (symbol-value list)))
  305.   
  306.   (UNWIND-PROTECT
  307.     (progn (batch-internal (setq file-obj (open filename)) demo-p)
  308.        (setq abortp nil)
  309.        (when $showtime
  310.          (format t "~&Batch spent ~$ seconds in evaluation.~%"
  311.              accumulated-time)))
  312.     (IF FILE-OBJ (CLOSE FILE-OBJ))
  313.     (when abortp (format t "~&(Batch of ~A aborted.)~%" filename))))
  314.  
  315.  
  316. (defun batch-internal (fileobj demo-p)
  317.   (CONTINUE (MAKE-ECHO-INPUT-STREAM
  318.           (MAKE-INPUT-STREAM fileobj "Batch Input Stream"))
  319.           (IF DEMO-P ':DEMO ':BATCH)))
  320. #-cl
  321. (DEFUN $BATCH (&REST ARG-LIST)
  322.   (BATCH (FILENAME-FROM-ARG-LIST ARG-LIST) NIL))
  323.  
  324. (DEFUN FILENAME-FROM-ARG-LIST (ARG-LIST)
  325.   (IF (= (LENGTH ARG-LIST) 1)
  326.       ($FILENAME_MERGE (CAR ARG-LIST))
  327.       ($FILENAME_MERGE `((MLIST),@ARG-LIST))))
  328.  
  329. (defmspec $grindef (form)
  330.   (eval `(grindef ,@(cdr form)))
  331.   '$DONE)
  332. #+cl
  333. (DEFUN $DEMO (&REST ARG-LIST)
  334.   (let ((tem ($file_search (car arg-list) $file_search_demo)))
  335.     (or tem (merror "Could not find ~M in  ~M: ~M" (car arg-list) '$file_search_demo $file_search_demo   ))
  336.     ($BATCH tem      '$demo)))
  337.  
  338. #-cl
  339. (DEFUN $DEMO (&REST ARG-LIST)
  340.   (BATCH (FILENAME-FROM-ARG-LIST ARG-LIST) T))
  341.  
  342. (defmfun $bug_report ()
  343.   (format t "~%The Maxima bug database is available at~%")
  344.   (format t "    http://sourceforge.net/tracker/?atid=104933&group_id=4933&func=browse~%")
  345.   (format t "Submit bug reports by following the 'Submit New' link on that page.~%")
  346.   (format t "Please include the following build information with your bug report:~%")
  347.   (format t "-------------------------------------------------------------~%")
  348.   ($build_info)
  349.   (format t "-------------------------------------------------------------~%")
  350.   (format t "The above information is also available from the Maxima function build_info().~%~%")
  351.   "")
  352.  
  353. (defmfun $build_info ()
  354.   (format t "~%Maxima version: ~a~%" *autoconf-version*)
  355.   (format t "Maxima build date: ~a:~a ~a/~a/~a~%"
  356.       (third user:*maxima-build-time*)
  357.       (second user:*maxima-build-time*)
  358.       (fifth user:*maxima-build-time*)
  359.       (fourth user:*maxima-build-time*)
  360.       (sixth user:*maxima-build-time*))
  361.   (format t "host type: ~a~%" *autoconf-host*)
  362.   (format t "lisp-implementation-type: ~a~%" (lisp-implementation-type))
  363.   (format t "lisp-implementation-version: ~a~%~%" (lisp-implementation-version))
  364.   "")
  365.  
  366. (defvar *maxima-started* nil)
  367.  
  368. #-lispm
  369. (defun macsyma-top-level (&OPTIONAL (input-stream *standard-input*)
  370.                     batch-flag)
  371.   (let ((*package* (find-package "MAXIMA")))
  372.     (if *maxima-started*
  373.     (format t "Maxima restarted.~%")
  374.       (progn
  375.     (format t "Maxima ~a http://maxima.sourceforge.net~%"
  376.         *autoconf-version*)
  377.     (format t "Distributed under the GNU Public License. See the file COPYING.~%")
  378.     (format t "Dedicated to the memory of William Schelter.~%")
  379.     (format t "This is a development version of Maxima. The function bug_report()~%")
  380.     (format t "provides bug reporting information.~%")
  381.     (setq *maxima-started* t)))
  382.     (if ($file_search "maxima-init.lisp") ($load "maxima-init.lisp"))
  383.     (if ($file_search "maxima-init.mac") ($batchload "maxima-init.mac"))
  384.     
  385.    (catch 'quit-to-lisp
  386.      (in-package "MAXIMA")
  387.      (sloop 
  388.      do
  389.        (catch #+kcl si::*quit-tag* #+cmu 'continue #-(or kcl cmu) nil
  390.           (catch 'macsyma-quit
  391.         (continue input-stream batch-flag)(bye)))))))
  392.  
  393. #-lispm
  394. (progn 
  395.  
  396. #+kcl
  397. (si::putprop :t 'throw-macsyma-top 'si::break-command)
  398.  
  399. (defun throw-macsyma-top ()
  400.   (throw 'macsyma-quit t))
  401.  
  402.  
  403. (defmfun $writefile (x) (dribble (subseq (string x) 1)))
  404. (defvar $appendfile nil )
  405. (defmfun $appendfile (name)
  406.   (if (and (symbolp name)
  407.        (member (getcharn name 1) '(#\& #\$)))
  408.       (setq name (subseq (symbol-name name) 1)))
  409.   (if $appendfile (merror "already in appendfile, use closefile first"))
  410.   (let ((stream  (open name :direction :output
  411.                                        :if-exists :append
  412.                                        :if-does-not-exist :create)))
  413.   (setq *appendfile-data* (list stream *terminal-io* name ))
  414.   
  415.   (setq $appendfile (make-two-way-stream
  416.              (make-echo-stream *terminal-io* stream)
  417.              (make-broadcast-stream *terminal-io* stream))
  418.     *terminal-io* $appendfile)
  419.   (multiple-value-bind (sec min hour day month year)
  420.                (get-decoded-time)
  421.                (format t
  422.                    "~&/* Starts dribbling to ~A (~d/~d/~d, ~d:~d:~d).*/"
  423.                    name year month day hour min sec))
  424.   '$done))
  425.   
  426. (defmfun $closefile ()
  427.   (cond ($appendfile
  428.      
  429.      (cond ((eq $appendfile *terminal-io*)
  430.                  (format t "~&/*Finished dribbling to ~A.*/"
  431.              (nth 2 *appendfile-data*))
  432.         (setq *terminal-io* (nth 1 *appendfile-data*))
  433.         )
  434.            (t  (warn "*TERMINAL-IO* was rebound while APPENDFILE is on.~%~
  435.                    You may miss some dribble output.")))
  436.      (close (nth 0 *appendfile-data*))
  437.      (setq *appendfile-data* nil $appendfile nil)
  438.      
  439.      )
  440.     (t (dribble))))
  441.  
  442.  
  443. (defmfun $ed (x) (ed (subseq (string x) 1))) 
  444.  
  445. (defmfun $cli () (process ":CLI.PR")) 
  446.  
  447. (defun nsubstring (x y) (subseq x y)) 
  448.  
  449. (defun filestrip (x) (subseq (string (car x)) 1)) 
  450. )
  451.  
  452. (defmspec $with_stdout ( arg) (setq arg (cdr arg))
  453.  (let ((body (cdr arg)) res)
  454.    (with-open-file (*standard-output* (NAMESTRING (stripdollar (car arg)))
  455.                       :direction :output)
  456.            (dolist (v body)
  457.                  (setq res (meval* v)))
  458.            res)))
  459.  
  460.  
  461.  
  462. (defun $sconcat(&rest x)
  463.   (let ((ans "") )
  464.   (dolist (v x)
  465.       (setq ans (concatenate 'string ans
  466.                    
  467.       (cond ((and (symbolp v) (eql (getcharn v 1)
  468.                        #\&))
  469.          (subseq (symbol-name v) 1))
  470.         ((stringp v) v)
  471.         (t
  472.          (coerce (mstring v) 'string))))))
  473.   ans))
  474.                     ;
  475.  
  476. #+gcl
  477. (defun $system (&rest x) (system (apply '$sconcat x)))
  478.  
  479. #+clisp
  480. (defun $system (&rest x) (ext:run-shell-command (apply '$sconcat x)))
  481.  
  482. #+cmu
  483. (defun $system (&rest args)
  484.   (ext:run-program "/bin/sh" (list "-c" (apply '$sconcat args))))
  485.  
  486. (defun $room (&optional (arg nil arg-p))
  487.   (if arg-p
  488.       (room arg)
  489.       (room)))
  490.