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 / compat.lisp < prev    next >
Encoding:
Text File  |  2003-02-09  |  6.5 KB  |  193 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. (in-package "MAXIMA")
  10. ;; Maclisp compatibility definitions for the Lisp Machine.  This file
  11. ;; is for Lisp differences only.  No knowledge of Macsyma should be
  12. ;; contained in this file.
  13.  
  14. ;; Translated code still uses this.
  15. (DEFQUOTE includef (  FILENAME) FILENAME)
  16.  
  17. ;; Couldn't this copy to some static area?
  18. (DEFMACRO PURCOPY (X) X)
  19.  
  20. (DEFMACRO CHARPOS (IGNOR)ignor  '(CDR (CURSORPOS)))
  21. (DEFMACRO MAXIMA-SLEEP (SECONDS) `(PROCESS-SLEEP (FIX (f* ,SECONDS 60.))))
  22.  
  23. (DEFUN LINEL (&OPTIONAL STREAM)
  24.        #+lispm 
  25.   (FUNCALL (SI:DECODE-PRINT-ARG STREAM) ':SIZE-IN-CHARACTERS)
  26.   #-lispm stream
  27.   #-lispm 80 
  28.   )
  29.  
  30. ;; Perhaps this should do something.
  31. (DEFMACRO NOINTERRUPT (IGNOR)ignor  NIL)
  32.  
  33. (DEFMACRO WITHOUT-TTY-INTERRUPTS (&REST FORM)
  34.   `(LET (#+lispm (TV:KBD-INTERCEPTED-CHARACTERS NIL))
  35.      ,@ FORM))
  36.  
  37. (DEFMACRO FIXNUM-IDENTITY (X) X)
  38. (DEFMACRO FLONUM-IDENTITY (X) X)
  39.  
  40. (proclaim '(inline *quo *dif))
  41. #+cl
  42. (DEFun *QUO (X Y)
  43.        (cond ((and (integerp x) (integerp y))
  44.           (truncate x y))
  45.          (t (/ X Y))))
  46. #+cl
  47. (DEFun *DIF (X Y) (- X Y))
  48.  
  49.  
  50. ;; Keep the compiler quiet.
  51. ;; Use GET-PNAME or FORMAT instead of EXPLODE, EXPLODEN, EXPLODEC.
  52. ;; Use AREF instead of GETCHAR and GETCHARN.
  53. ;; Use MAKE-SYMBOL instead of MAKNAM.
  54. ;; Use INTERN instead of IMPLODE.
  55. ;; Use STRING-LESSP instead of ALPHALESSP.
  56. #+lispm 
  57. (progn 
  58. (REMPROP 'EXPLODE       'COMPILER:STYLE-CHECKER)
  59. (REMPROP 'EXPLODEC      'COMPILER:STYLE-CHECKER)
  60. (REMPROP 'EXPLODEN      'COMPILER:STYLE-CHECKER)
  61. (REMPROP 'ALPHALESSP    'COMPILER:STYLE-CHECKER)
  62. (REMPROP 'GETCHARN      'COMPILER:STYLE-CHECKER)
  63. (REMPROP 'GETCHAR       'COMPILER:STYLE-CHECKER)
  64. (REMPROP 'IMPLODE       'COMPILER:STYLE-CHECKER)
  65. (REMPROP 'MAKNAM        'COMPILER:STYLE-CHECKER)
  66. )
  67.  
  68. (DEFMACRO SFA-CALL (STREAM OPERATION ARG)
  69.   `(FUNCALL ,STREAM (READ-FROM-STRING (STRING-APPEND #\: ,OPERATION)) ,ARG))
  70.  
  71. ;; Things that appear within DECLARE bodies.
  72.  
  73. ;; Why doesn't this work?
  74. ;; Because of the brain-damaged way the lispm compiler is written. -gjc
  75. ;; (PUTPROP 'DECLARE '(DECLARE-OPTIMIZER) 'COMPILER:OPTIMIZERS)
  76. ;;
  77. ;; (DEFUN DECLARE-OPTIMIZER (DECLARE-FORM &AUX (RETURN-FORM NIL))
  78. ;;   (DO ((L (REVERSE (CDR DECLARE-FORM)) (CDR L)))
  79. ;;       ((NULL L))
  80. ;;     (IF (NOT (MEMQ (CAAR L)
  81. ;;            '(FIXNUM FLONUM NOTYPE MACROS ARRAY* GENPREFIX
  82. ;;                 CLOSED MUZZLED MAPEX SPLITFILE)))
  83. ;;     (PUSH (CAR L) RETURN-FORM)))
  84. ;;   (IF RETURN-FORM (CONS 'DECLARE RETURN-FORM) NIL))
  85.  
  86. ;; These are in global, so avoid redefinition warning by using FDEFINE
  87. ;; rather than DEFun.
  88.  
  89. ;(FDEFINE (kw FLONUM) #'(LAMBDA ( &REST IGNOR)ignor  NIL))
  90. ;(FDEFINE (kw FIXNUM) #'(LAMBDA ("E &REST IGNOR)ignor  NIL))
  91. ;(FDEFINE 'ARGS     #'(LAMBDA ("E &REST IGNOR)ignor  NIL))
  92.  
  93. (DEFMACRO ARGS (&REST IGNOR)ignor  NIL)
  94.  
  95. #-cl
  96. (progn
  97. (DEFMACRO FLONUM (&REST IGNOR)ignor  NIL)
  98. (DEFMACRO FIXNUM (&REST IGNOR)ignor  NIL)
  99. (DEFMACRO MACROS         ( &REST IGNOR)ignor  NIL)
  100. (DEFMACRO CLOSED         ( &REST IGNOR)ignor  NIL)
  101. (DEFMACRO NOTYPE         ( &REST IGNOR)ignor  NIL)
  102. (DEFMACRO ARRAY*         ( &REST IGNOR)ignor  NIL)
  103. (DEFMACRO GENPREFIX     ( &REST IGNOR)ignor  NIL)
  104. (DEFMACRO MUZZLED         ( &REST IGNOR)ignor  NIL)
  105. (DEFMACRO MAPEX         ( &REST IGNOR)ignor  NIL)
  106. (DEFMACRO SPLITFILE     ( &REST IGNOR)ignor  NIL)
  107. (DEFMACRO EXPR-HASH     ( &REST IGNOR)ignor  NIL)
  108. )
  109. ;; Run time stuff
  110.  
  111. (DEFUN SYMBOLCONC (&REST SYMS)
  112.   (INTERN (APPLY #'concatenate 'string
  113.          (MAPCAR #'(LAMBDA (SYM)
  114.                  (COND ((FLOATP SYM)
  115.                     (FORMAT NIL "~S" SYM))
  116.                    ((INTEGERP SYM)
  117.                     (FORMAT NIL "~D" SYM))
  118.                    ((symbolp sym)
  119.                     (symbol-name sym))
  120.                    (T SYM)))
  121.              SYMS))))
  122.  
  123. ;(DEFUN QUOTED-ARGS ("E &REST L)
  124. ;  (MAPCAR #'(LAMBDA (X) (PUTPROP X '((1005 (FEF-ARG-OPT FEF-QT-QT))) 'ARGDESC))
  125. ;      L))
  126.  
  127.  
  128.  
  129. (DEFMACRO QUOTE-ARGS ( &REST L)
  130.   `(QUOTED-ARGS-AUX ',L))
  131. (DEFUN QUOTED-ARGS-AUX (L)
  132.   (MAPCAR #'(LAMBDA (X) (PUTPROP X '((1005 (FEF-ARG-OPT FEF-QT-QT))) 'ARGDESC))
  133.       L))
  134.  
  135.  
  136. #+cl
  137. (PROGN 'COMPILE
  138.  
  139. ;;; On the 3600, STORE isn't implemented.  So, implement enough of
  140. ;;; it here to satisfy the cases the Macsyma uses.  I have yet to find
  141. ;;; it using complicated side effects of the array reference -- it's either
  142. ;;; a (STORE (ARRAYCALL ...) ...) or a (STORE (FUNCALL ...) ...) or else
  143. ;;; a (STORE (array-called-as-function ...) ...).  So, assume that if the CAR
  144. ;;; of the first form isn't ARRAYCALL or FUNCALL, then it's a STORE of the third
  145. ;;; form.
  146.  
  147. (DEFUN STORE-MACRO-HELPER (ARRAY-REF NEW-VALUE)
  148.   ;;this is redundant and should be caught by store but a bug in compiler..
  149.   (cond ((or (eql (car array-ref) 'aref))(equal (car array-ref) '(function aref))
  150.      `(setf (aref ,@ (cdr array-ref)) ,new-value))
  151.     (t
  152.   (CASE (LENGTH ARRAY-REF)
  153.     (2 `(STORE-INTERNAL-1D ,@ARRAY-REF ,NEW-VALUE))
  154.     (3 `(STORE-INTERNAL-2D ,@ARRAY-REF ,NEW-VALUE))
  155.     (OTHERWISE (ERROR "Cannot expand STORE for array reference ~S" ARRAY-REF))))))
  156.  
  157.  
  158.  
  159. (DEFMACRO STORE (ARRAY-REF NEW-VALUE &aux expand-1 )
  160.   (cond ((not (memq (car array-ref ) '(aref arraycall)))
  161.      (setq expand-1 (macroexpand-1 array-ref))
  162.      (setq array-ref
  163.            (cond ((memq (car expand-1 ) '(aref arraycall))
  164.               expand-1)
  165.              (t  (macroexpand array-ref))))))
  166.   
  167.   (CASE (FIRST ARRAY-REF)
  168.     (FUNCALL (STORE-MACRO-HELPER (CDR ARRAY-REF) NEW-VALUE))
  169. ;    (ARRAYCALL (STORE-MACRO-HELPER (CDDR ARRAY-REF) NEW-VALUE))
  170.     ;;the arrays ought to all be on in the symbol location by now --wfs
  171.     (ARRAYCALL `(setf ,array-ref ,new-value))
  172.     (aref `(setf ,array-ref ,new-value))
  173.     (OTHERWISE (STORE-MACRO-HELPER `(#',(FIRST ARRAY-REF) . ,(CDR ARRAY-REF)) NEW-VALUE))))
  174.  
  175.  
  176. (DEFUN STORE-INTERNAL-1D (ARRAY-SPEC INDEX NEW-VALUE)
  177.   (SLOOP UNTIL (ARRAYP ARRAY-SPEC)
  178.     DO (COND ((SYMBOLP ARRAY-SPEC) (SETQ ARRAY-SPEC (SYMBOL-ARRAY ARRAY-SPEC)))
  179.          (T (ERROR "STORE failed -- can't find array for ~S" ARRAY-SPEC))))
  180.   (SETF (AREF ARRAY-SPEC INDEX) NEW-VALUE))
  181.  
  182. (DEFUN STORE-INTERNAL-2D (ARRAY-SPEC I1 I2 NEW-VALUE)
  183.   (SLOOP UNTIL (ARRAYP ARRAY-SPEC)
  184.     DO (COND ((SYMBOLP ARRAY-SPEC) (SETQ ARRAY-SPEC (SYMBOL-ARRAY ARRAY-SPEC)))
  185.          (T (ERROR "STORE failed -- can't find array for ~S" ARRAY-SPEC))))
  186.   (SETF (AREF ARRAY-SPEC I1 I2) NEW-VALUE))
  187.  
  188. )  ;End PROGN 'COMPILE
  189.  
  190.  
  191.  
  192.  
  193.