1;; -*- Mode: Lisp; Package: Maxima; Syntax: Common-Lisp; Base: 10 -*- ;;;; 2;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 3;;; ;;;;; 4;;; Copyright (c) 1984,1987 by William Schelter,University of Texas ;;;;; 5;;; All rights reserved ;;;;; 6;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 7 8(in-package :maxima) 9 10(defmacro defun-prop (f arg &body body) 11 (assert (listp f)) 12 #+gcl (eval-when (eval) (compiler::compiler-def-hook (first f) body)) 13 `(setf (get ',(first f) ',(second f)) #'(lambda ,arg ,@body))) 14 15(defvar *prin1* nil) ;a function called instead of prin1. 16 17;; Should we give this a different name? 18(defvar *fortran-print* nil 19 "Tells EXPLODEN we are printing numbers for Fortran so include the exponent marker.") 20 21(defun appears (tree var) 22 (cond ((equal tree var) 23 (throw 'appears t)) 24 ((atom tree) nil) 25 (t (appears (car tree) var) 26 (appears (cdr tree) var))) 27 nil) 28 29(defun appears1 (tree var) 30 (cond ((eq tree var) 31 (throw 'appears t)) 32 ((atom tree) nil) 33 (t 34 (appears (car tree) var) 35 (appears (cdr tree) var))) 36 nil) 37 38(defun appears-in (tree var) 39 "Yields t if var appears in tree" 40 (catch 'appears 41 (if (or (symbolp var) (fixnump var)) 42 (appears1 tree var) 43 (appears tree var)))) 44 45;; A more portable implementation of ml-typep. I (rtoy) think it 46;; would probably be better to replace uses of 47;; ml-typep with the corresponding Common Lisp typep or type-of or 48;; subtypep, as appropriate. 49(defun ml-typep (x &optional type) 50 (cond (type 51 (cl:let ((pred (get type 'ml-typep))) 52 (if pred 53 (funcall pred x) 54 (typep x type)))) 55 (t 56 (typecase x 57 (cl:cons 'list) 58 (cl:fixnum 'fixnum) 59 (cl:integer 'bignum) 60 (cl:float 'flonum) 61 (cl:number 'number) 62 (cl:array 'array) 63 (cl:hash-table 'hash-table) 64 (t 65 (type-of x)))))) 66 67(defprop :extended-number extended-number-p ml-typep) 68(defprop array arrayp ml-typep) 69(defprop atom atom ml-typep) 70 71#+(or cmu scl) 72(eval-when (:compile-toplevel :load-toplevel :execute) 73 (shadow '(cl:compiled-function-p) (find-package :maxima)) 74) 75#+(or cmu scl) 76(defun compiled-function-p (x) 77 (and (functionp x) (not (symbolp x)) 78 (not (eval:interpreted-function-p x)))) 79 80(defprop compiled-function compiled-function-p ml-typep) 81(defprop extended-number extended-number-p ml-typep) 82(defprop fixnum fixnump ml-typep) 83(defprop list consp ml-typep) 84(defprop number numberp ml-typep) 85(defprop string stringp ml-typep) 86(defprop symbol symbolp ml-typep) 87 88 89(defvar *maxima-arrays* nil 90 "Trying to track down any functional arrays in maxima") 91 92(defun *array (name maclisp-type &rest dimlist &aux aarray) 93 (cond ((member maclisp-type '(readtable obarray) :test #'eq) 94 (error " bad type ~S" maclisp-type))) 95 (pushnew name *maxima-arrays*) ;for tracking down old ones. 96 (setq aarray (make-array dimlist :initial-element (case maclisp-type 97 (fixnum 0) 98 (flonum 0.0) 99 (otherwise nil)))) 100 (cond ((null name) aarray) 101 ((symbolp name) 102 (setf (symbol-array name) aarray) 103 name) 104 (t (error "~S is illegal first arg for *array" name)))) 105 106;;; Change maclisp array referencing. 107;;; Idea1: Make changes in the code which will allow the code to still run in maclisp, 108;;;yet will allow, with the appropriate macro definitions of array,arraycall, etc, 109;;;to put the array into the value-cell. 110;;; Idea2: Make changes in the array referencing of (a dim1 dim2..) to (arraycall nil (symbol-array a) dim1..) 111;;;which would then allow expansion into something which is common lisp compatible, for 112;;;the day when (a 2 3) no longer is equivalent to (aref (symbol-function a) 2 3). 113;;;I. change (array a typ dim1 dim2..) to expand to (defvar a (make-array (list dim1 dim2 ...) :type typ') 114;;;II. change (a dim1 dim2..) to (arraycall nil (symbol-array a) dim1 dim2 ..) 115;;;III define 116;;(defmacro symbol-array (ar) 117;; `(symbol-function ,ar)) 118;;(defmacro arraycall (ignore ar &rest dims) 119;; `(aref ,ar ,@ dims)) 120;;;IV. change array setting to use (setf (arraycall nil ar dim1.. ) val) 121;;;which will generate the correct setting code on the lispm and will 122;;;still work in maclisp. 123 124(defmacro maxima-error (datum &rest args) 125 `(cerror "without any special action" ,datum ,@args)) 126 127(defmacro show (&rest l) 128 (loop for v in l 129 collecting `(format t "~%The value of ~A is ~A" ',v ,v) into tem 130 finally (return `(progn ,@ tem)))) 131 132(defmacro defquote (fn (aa . oth) &body rest &aux help ans) 133 (setq help (intern (format nil "~a-~a" fn '#:aux))) 134 (cond ((eq aa '&rest) 135 (setq ans 136 (list 137 `(defmacro ,fn (&rest ,(car oth)) 138 `(,',help ',,(car oth))) 139 `(defun ,help (,(car oth)) ,@rest)))) 140 (t (when (member '&rest oth) 141 (error "at present &rest may only occur as first item in a defquote argument")) 142 (setq ans 143 (list 144 `(defmacro ,fn (,aa . other) 145 (setq other (loop for v in other collecting (list 'quote v))) 146 (check-arg other (eql (length other) ,(length oth)) 147 ,(format nil "wrong number of args to ~a" fn)) 148 `(,',help ',,aa ,@ other)) 149 `(defun ,help (,aa ,@ oth) ,@rest))))) 150 `(progn ,@ans)) 151 152 153;;the resulting function will translate to defvar and will behave 154;;correctly for the evaluator. 155 156;;(defun gg fexpr (ll) 157;; body) 158;;(defquote gg (&rest ll) 159;; body) 160 161;;(DEFQUOTE GG ( &rest C) 162;; (list (car c) (second c) )) 163;;the big advantage of using the following over defmspec is that it 164;;seems to translate more easily, since it is a fn. 165;;New functions which wanted quoted arguments should be defined using 166;;defquote 167 168 169(defun onep (x) (eql 1 x)) 170 171(defun extended-number-p (x) 172 (member (type-of x) '(bignum rational float ))) 173 174(defvar *scan-string-buffer* nil) 175 176(defun macsyma-read-string (a-string &aux answer) 177 (cond ((not (or (search "$" a-string :test #'char-equal) 178 (search ";" a-string :test #'char-equal))) 179 (vector-push-extend #\$ a-string))) 180 (with-input-from-string (stream a-string) 181 (setq answer (third (mread stream))) 182 answer)) 183 184(defvar *sharp-read-buffer* 185 (make-array 140 :element-type ' #.(array-element-type "a") :fill-pointer 0 :adjustable t)) 186 187(defmfun $-read-aux (arg stream &aux (meval-flag t) (*mread-prompt* "")) 188 (declare (special *mread-prompt*) 189 (ignore arg)) 190 (setf (fill-pointer *sharp-read-buffer*) 0) 191 (cond ((eql #\$ (peek-char t stream)) 192 (tyi stream) 193 (setq meval-flag nil))) 194 (with-output-to-string (st *sharp-read-buffer*) 195 (let (char) 196 (loop while (not (eql char #\$)) 197 do 198 (setq char (tyi stream)) 199 (write-char char st)))) 200 (if meval-flag 201 (list 'meval* (list 'quote (macsyma-read-string *sharp-read-buffer*))) 202 (list 'quote (macsyma-read-string *sharp-read-buffer*)))) 203 204(defun x$-cl-macro-read (stream sub-char arg) 205 (declare (ignore arg)) 206 ($-read-aux sub-char stream)) 207 208(set-dispatch-macro-character #\# #\$ #'x$-cl-macro-read) 209 210(defvar *macsyma-readtable*) 211 212(defun find-lisp-readtable-for-macsyma () 213 (cond ((and (boundp '*macsyma-readtable*) 214 (readtablep *macsyma-readtable*)) 215 *macsyma-readtable*) 216 (t (setq *macsyma-readtable* (copy-readtable nil)) 217 (set-dispatch-macro-character #\# #\$ 'x$-cl-macro-read *macsyma-readtable*) 218 *macsyma-readtable*))) 219 220(defun set-readtable-for-macsyma () 221 (setq *readtable* (find-lisp-readtable-for-macsyma))) 222 223(defvar *reset-var* t) 224 225(defvar *variable-initial-values* (make-hash-table) 226 "Hash table containing all Maxima defmvar variables and their initial 227values") 228 229(defmacro defmvar (var &rest val-and-doc) 230 "If *reset-var* is true then loading or eval'ing will reset value, otherwise like defvar" 231 (cond ((> (length val-and-doc) 2) 232 (setq val-and-doc (list (car val-and-doc) (second val-and-doc))))) 233 `(progn 234 (unless (gethash ',var *variable-initial-values*) 235 (setf (gethash ',var *variable-initial-values*) 236 ,(first val-and-doc))) 237 (defvar ,var ,@val-and-doc))) 238 239(defmfun $mkey (variable) 240 "($mkey '$demo)==>:demo" 241 (intern (string-left-trim "$" (string variable)) 'keyword)) 242 243(defmacro arg (x) 244 `(narg1 ,x narg-rest-argument)) 245 246(defun narg1 (x l &aux tem) 247 (cond ((null x) (length l)) 248 (t (setq tem (nthcdr (1- x) l)) 249 (cond ((null tem) (error "arg ~A beyond range ~A " x (length l))) 250 (t (car tem)))))) 251 252(defmacro listify (x) 253 `(listify1 ,x narg-rest-argument)) 254 255(defmacro setarg (i val) 256 `(setarg1 ,i ,val narg-rest-argument)) 257 258(defun setarg1 (i val l) 259 (setf (nth (1- i) l) val) 260 val) 261 262(defun listify1 (n narg-rest-argument) 263 (cond ((minusp n) (copy-list (last narg-rest-argument (- n))) ) 264 ((zerop n) nil) 265 (t (subseq narg-rest-argument 0 n)))) 266 267;; This has been replaced by src/defmfun-check.lisp. I'm leaving this 268;; here for now until we finish up fixing everything like using defun 269;; for internal functions and updating user-exposed functions to use 270;; defmfun instead of defun. 271#+nil 272(defmacro defmfun (function &body rest &aux .n.) 273 (cond ((and (car rest) (symbolp (car rest))) 274 ;;old maclisp narg syntax 275 (setq .n. (car rest)) 276 (setf (car rest) 277 `(&rest narg-rest-argument &aux (, .n. (length narg-rest-argument)))))) 278 `(progn 279 ;; I (rtoy) think we can consider all defmfun's as translated functions. 280 (defprop ,function t translated) 281 (defun ,function . ,rest))) 282 283;;sample usage 284;;(defun foo a (show a )(show (listify a)) (show (arg 3))) 285 286(defmacro defun-maclisp (function &body rest &aux .n.) 287 (cond ((and (car rest) (symbolp (car rest))) 288 ;;old maclisp narg syntax 289 (setq .n. (car rest)) 290 (setf (car rest) 291 `(&rest narg-rest-argument &aux (, .n. (length narg-rest-argument)))))) 292 `(progn 293 ;; I (rtoy) think we can consider all defmfun's as translated functions. 294 (defprop ,function t translated) 295 (defun ,function . ,rest))) 296 297(defun exploden (symb) 298 (let* (#+(and gcl (not gmp)) (big-chunk-size 120) 299 #+(and gcl (not gmp)) (tentochunksize (expt 10 big-chunk-size)) 300 string) 301 (cond ((symbolp symb) 302 (setq string (print-invert-case symb))) 303 ((floatp symb) 304 (setq string (exploden-format-float symb))) 305 306 ((integerp symb) 307 ;; When obase > 10, prepend leading zero to 308 ;; ensure that output is readable as a number. 309 (let ((leading-digit (if (> *print-base* 10) #\0))) 310 (cond 311 #+(and gcl (not gmp)) 312 ((bignump symb) 313 (let* ((big symb) 314 ans rem tem 315 (chunks 316 (loop 317 do (multiple-value-setq (big rem) 318 (floor big tentochunksize)) 319 collect rem 320 while (not (eql 0 big))))) 321 (setq chunks (nreverse chunks)) 322 (setq ans (coerce (format nil "~d" (car chunks)) 'list)) 323 (if (and leading-digit (not (digit-char-p (car ans) 10.))) 324 (setq ans (cons leading-digit ans))) 325 (loop for v in (cdr chunks) 326 do (setq tem (coerce (format nil "~d" v) 'list)) 327 (loop for i below (- big-chunk-size (length tem)) 328 do (setq tem (cons #\0 tem))) 329 (setq ans (nconc ans tem))) 330 (return-from exploden ans))) 331 (t 332 (setq string (format nil "~A" symb)) 333 (setq string (coerce string 'list)) 334 (if (and leading-digit (not (digit-char-p (car string) 10.))) 335 (setq string (cons leading-digit string))) 336 (return-from exploden string))))) 337 338 (t (setq string (format nil "~A" symb)))) 339 (assert (stringp string)) 340 (coerce string 'list))) 341 342(defvar *exploden-strip-float-zeros* t) ;; NIL => allow trailing zeros 343 344(defun exploden-format-float (symb) 345 (declare (special $maxfpprintprec)) 346 (let ((a (abs symb)) 347 string 348 (effective-printprec (if (or (= $fpprintprec 0) 349 (> $fpprintprec $maxfpprintprec)) 350 $maxfpprintprec 351 $fpprintprec))) 352 ;; When printing out something for Fortran, we want to be 353 ;; sure to print the exponent marker so that Fortran 354 ;; knows what kind of number it is. It turns out that 355 ;; Fortran's exponent markers are the same as Lisp's so 356 ;; we just need to make sure the exponent marker is 357 ;; printed. 358 (if *fortran-print* 359 (setq string (cond 360 ;; Strings for non-finite numbers as specified for input in Fortran 2003 spec; 361 ;; they apparently did not exist in earlier versions. 362 ((float-nan-p symb) "NAN") 363 ((float-inf-p symb) (if (< symb 0) "-INF" "INF")) 364 (t (format nil "~e" symb)))) 365 (multiple-value-bind (form digits) 366 (cond 367 ((zerop a) 368 (values "~,vf" 1)) 369 ;; Work around for GCL bug #47404. 370 ;; Avoid numeric comparisons with NaN, which erroneously return T. 371 #+gcl ((or (float-inf-p symb) (float-nan-p symb)) 372 (return-from exploden-format-float (format nil "~a" symb))) 373 ((<= 0.001 a 1e7) 374 (let* 375 ((integer-log10 (floor (/ (log a) #.(log 10.0)))) 376 (scale (1+ integer-log10))) 377 (if (< scale effective-printprec) 378 (values "~,vf" (- effective-printprec scale)) 379 (values "~,ve" (1- effective-printprec))))) 380 #-gcl ((or (float-inf-p symb) (float-nan-p symb)) 381 (return-from exploden-format-float (format nil "~a" symb))) 382 (t 383 (values "~,ve" (1- effective-printprec)))) 384 385 ;; Call FORMAT using format string chosen above. 386 (setq string (format nil form digits a)) 387 388 ;; EXPLODEN is often called after NFORMAT, so it doesn't 389 ;; usually see a negative argument. I can't guarantee 390 ;; a non-negative argument, so handle negative here. 391 (if (< symb 0) 392 (setq string (concatenate 'string "-" string))))) 393 394 (if *exploden-strip-float-zeros* 395 (or (strip-float-zeros string) string) 396 string))) 397 398(defun trailing-zeros-regex-f-0 (s) (funcall #.(maxima-nregex::regex-compile "^(.*\\.[0-9]*[1-9])00*$") s)) 399(defun trailing-zeros-regex-f-1 (s) (funcall #.(maxima-nregex::regex-compile "^(.*\\.0)00*$") s)) 400(defun trailing-zeros-regex-e-0 (s) (funcall #.(maxima-nregex::regex-compile "^(.*\\.[0-9]*[1-9])00*([^0-9][+-][0-9]*)$") s)) 401(defun trailing-zeros-regex-e-1 (s) (funcall #.(maxima-nregex::regex-compile "^(.*\\.0)00*([^0-9][+-][0-9]*)$") s)) 402 403;; Return S with trailing zero digits stripped off, or NIL if there are none. 404 405(defun strip-float-zeros (s) 406 (cond 407 ((or (trailing-zeros-regex-f-0 s) (trailing-zeros-regex-f-1 s)) 408 (let 409 ((group1 (aref maxima-nregex::*regex-groups* 1))) 410 (subseq s (first group1) (second group1)))) 411 ((or (trailing-zeros-regex-e-0 s) (trailing-zeros-regex-e-1 s)) 412 (let* 413 ((group1 (aref maxima-nregex::*regex-groups* 1)) 414 (s1 (subseq s (first group1) (second group1))) 415 (group2 (aref maxima-nregex::*regex-groups* 2)) 416 (s2 (subseq s (first group2) (second group2)))) 417 (concatenate 'string s1 s2))) 418 (t nil))) 419 420(defun explodec (symb) ;is called for symbols and numbers 421 (loop for v in (coerce (print-invert-case symb) 'list) 422 collect (intern (string v)))) 423 424;;; If the 'string is all the same case, invert the case. Otherwise, 425;;; do nothing. 426#-(or scl allegro) 427(defun maybe-invert-string-case (string) 428 (let ((all-upper t) 429 (all-lower t) 430 (length (length string))) 431 (dotimes (i length) 432 (let ((ch (char string i))) 433 (when (both-case-p ch) 434 (if (upper-case-p ch) 435 (setq all-lower nil) 436 (setq all-upper nil))))) 437 (cond (all-upper 438 (string-downcase string)) 439 (all-lower 440 (string-upcase string)) 441 (t 442 string)))) 443 444#+(or scl allegro) 445(defun maybe-invert-string-case (string) 446 (cond (#+scl (eq ext:*case-mode* :lower) 447 #+allegro (eq excl:*current-case-mode* :case-sensitive-lower) 448 string) 449 (t 450 (let ((all-upper t) 451 (all-lower t) 452 (length (length string))) 453 (dotimes (i length) 454 (let ((ch (aref string i))) 455 (when (both-case-p ch) 456 (if (upper-case-p ch) 457 (setq all-lower nil) 458 (setq all-upper nil))))) 459 (cond (all-upper 460 (string-downcase string)) 461 (all-lower 462 (string-upcase string)) 463 (t 464 string)))))) 465 466(defun intern-invert-case (string) 467 ;; Like read-from-string with readtable-case :invert 468 ;; Supply package argument in case this function is called 469 ;; from outside the :maxima package. 470 (intern (maybe-invert-string-case string) :maxima)) 471 472 473#-(or gcl scl allegro) 474(let ((local-table (copy-readtable nil))) 475 (setf (readtable-case local-table) :invert) 476 (defun print-invert-case (sym) 477 (let ((*readtable* local-table) 478 (*print-case* :upcase)) 479 (princ-to-string sym)))) 480 481#+(or scl allegro) 482(let ((local-table (copy-readtable nil))) 483 (unless #+scl (eq ext:*case-mode* :lower) 484 #+allegro (eq excl:*current-case-mode* :case-sensitive-lower) 485 (setf (readtable-case local-table) :invert)) 486 (defun print-invert-case (sym) 487 (cond (#+scl (eq ext:*case-mode* :lower) 488 #+allegro (eq excl:*current-case-mode* :case-sensitive-lower) 489 (let ((*readtable* local-table) 490 (*print-case* :downcase)) 491 (princ-to-string sym))) 492 (t 493 (let ((*readtable* local-table) 494 (*print-case* :upcase)) 495 (princ-to-string sym)))))) 496 497#+gcl 498(defun print-invert-case (sym) 499 (cond ((symbolp sym) 500 (let* ((str (princ-to-string sym)) 501 (have-upper nil) 502 (have-lower nil) 503 (converted-str 504 (map 'string (lambda (c) 505 (cond ((upper-case-p c) 506 (setf have-upper t) 507 (char-downcase c)) 508 ((lower-case-p c) 509 (setf have-lower t) 510 (char-upcase c)) 511 (t c))) 512 str))) 513 (if (and have-upper have-lower) 514 str 515 converted-str))) 516 (t (princ-to-string sym)))) 517 518(defun implode (list) 519 (declare (optimize (speed 3))) 520 (intern-invert-case (map 'string #'(lambda (v) 521 (etypecase v 522 (character v) 523 (symbol (char (symbol-name v) 0)) 524 (integer (code-char v)))) 525 list))) 526 527;; Note: symb can also be a number, not just a symbol. 528(defun explode (symb) 529 (declare (optimize (speed 3))) 530 (map 'list #'(lambda (v) (intern (string v))) (format nil "~a" symb))) 531 532;;; return the first character of the name of a symbol or a string or char 533(defun get-first-char (symb) 534 (declare (optimize (speed 3))) 535 (char (string symb) 0)) 536 537(defun getchar (symb i) 538 (let ((str (string symb))) 539 (if (<= 1 i (length str)) 540 (intern (string (char str (1- i)))) 541 nil))) 542 543(defun ascii (n) 544 (intern (string n))) 545 546(defun maknam (lis) 547 (loop for v in lis 548 when (symbolp v) 549 collecting (char (symbol-name v) 0) into tem 550 else 551 when (characterp v) 552 collecting v into tem 553 else do (maxima-error "bad entry") 554 finally 555 (return (make-symbol (maybe-invert-string-case (coerce tem 'string)))))) 556 557;;for those window labels etc. that are wrong type. 558;; is not only called for symbols, but also on numbers 559(defun flatc (sym) 560 (length (explodec sym))) 561 562(defun flatsize (sym &aux (*print-circle* t)) 563 (length (exploden sym))) 564 565(defmacro safe-zerop (x) 566 (if (symbolp x) 567 `(and (numberp ,x) (zerop ,x)) 568 `(let ((.x. ,x)) 569 (and (numberp .x.) (zerop .x.))))) 570 571(defmacro signp (sym x) 572 (cond ((atom x) 573 (let ((test 574 (case sym 575 (e `(zerop ,x)) 576 (l `(< ,x 0)) 577 (le `(<= ,x 0)) 578 (g `(> ,x 0)) 579 (ge `(>= ,x 0)) 580 (n `(not (zerop ,x)))))) 581 `(and (numberp ,x) ,test))) 582 (t `(let ((.x. ,x)) 583 (signp ,sym .x.))))) 584 585(defvar *prompt-on-read-hang* nil) 586(defvar *read-hang-prompt* "") 587 588(defun tyi-raw (&optional (stream *standard-input*) eof-option) 589 ;; Adding this extra EOF test, because the testsuite generates 590 ;; unexpected end of input-stream with Windows XP and GCL 2.6.8. 591 #+gcl 592 (when (eql (peek-char nil stream nil eof-option) eof-option) 593 (return-from tyi-raw eof-option)) 594 595 (let ((ch (read-char-no-hang stream nil eof-option))) 596 (if ch 597 ch 598 (progn 599 (when (and *prompt-on-read-hang* *read-hang-prompt*) 600 (princ *read-hang-prompt*) 601 (finish-output *standard-output*)) 602 (read-char stream nil eof-option))))) 603 604(defun tyi (&optional (stream *standard-input*) eof-option) 605 (let ((ch (tyi-raw stream eof-option))) 606 (if (eql ch eof-option) 607 ch 608 (backslash-check ch stream eof-option)))) 609 610; The sequences of characters 611; <anything-except-backslash> 612; (<backslash> <newline> | <backslash> <return> | <backslash> <return> <newline>)+ 613; <anything> 614; are reduced to <anything-except-backslash> <anything> . 615; Note that this has no effect on <backslash> <anything-but-newline-or-return> . 616 617(let ((previous-tyi #\a)) 618 (defun backslash-check (ch stream eof-option) 619 (if (eql previous-tyi #\\ ) 620 (progn (setq previous-tyi #\a) ch) 621 (setq previous-tyi 622 (if (eql ch #\\ ) 623 (let ((next-char (peek-char nil stream nil eof-option))) 624 (if (or (eql next-char #\newline) (eql next-char #\return)) 625 (eat-continuations ch stream eof-option) 626 ch)) 627 ch)))) 628 ; We have just read <backslash> and we know the next character is <newline> or <return>. 629 ; Eat line continuations until we come to something which doesn't match, or we reach eof. 630 (defun eat-continuations (ch stream eof-option) 631 (setq ch (tyi-raw stream eof-option)) 632 (do () ((not (or (eql ch #\newline) (eql ch #\return)))) 633 (let ((next-char (peek-char nil stream nil eof-option))) 634 (if (and (eql ch #\return) (eql next-char #\newline)) 635 (tyi-raw stream eof-option))) 636 (setq ch (tyi-raw stream eof-option)) 637 (let ((next-char (peek-char nil stream nil eof-option))) 638 (if (and (eql ch #\\ ) (or (eql next-char #\return) (eql next-char #\newline))) 639 (setq ch (tyi-raw stream eof-option)) 640 (return-from eat-continuations ch)))) 641 ch)) 642 643(defvar ^w nil) 644 645(defmfun $timedate (&optional (time (get-universal-time)) tz) 646 (cond 647 ((and (consp tz) (eq (caar tz) 'rat)) 648 (setq tz (/ (second tz) (third tz)))) 649 ((floatp tz) 650 (setq tz (rationalize tz)))) 651 (if tz (setq tz (/ (round tz 1/60) 60))) 652 (let* 653 ((time-integer (mfuncall '$floor time)) 654 (time-fraction (sub time time-integer)) 655 (time-millis (mfuncall '$round (mul 1000 time-fraction)))) 656 (when (= time-millis 1000) 657 (setq time-integer (1+ time-integer)) 658 (setq time-millis 0)) 659 (multiple-value-bind 660 (second minute hour date month year day-of-week dst-p tz) 661 ;; Some Lisps allow TZ to be null but CLHS doesn't explicitly allow it, 662 ;; so work around null TZ here. 663 (if tz (decode-universal-time time-integer (- tz)) 664 (decode-universal-time time-integer)) 665 (declare (ignore day-of-week #+gcl dst-p)) 666 ;; DECODE-UNIVERSAL-TIME might return a timezone offset 667 ;; which is a multiple of 1/3600 but not 1/60. 668 ;; We need a multiple of 1/60 because our formatted 669 ;; timezone offset has only minutes and seconds. 670 (if (/= (mod tz 1/60) 0) 671 ($timedate time-integer (/ (round (- tz) 1/60) 60)) 672 (let ((tz-offset 673 #-gcl (if dst-p (- 1 tz) (- tz)) 674 #+gcl (- tz) ; bug in gcl https://savannah.gnu.org/bugs/?50570 675 )) 676 (multiple-value-bind 677 (tz-hours tz-hour-fraction) 678 (truncate tz-offset) 679 (let 680 ((tz-sign (if (<= 0 tz-offset) #\+ #\-))) 681 (if (= time-millis 0) 682 (format nil "~4,'0d-~2,'0d-~2,'0d ~2,'0d:~2,'0d:~2,'0d~a~2,'0d:~2,'0d" 683 year month date hour minute second tz-sign (abs tz-hours) (floor (* 60 (abs tz-hour-fraction)))) 684 (format nil "~4,'0d-~2,'0d-~2,'0d ~2,'0d:~2,'0d:~2,'0d.~3,'0d~a~2,'0d:~2,'0d" 685 year month date hour minute second time-millis tz-sign (abs tz-hours) (floor (* 60 (abs tz-hour-fraction)))))))))))) 686 687;; Parse date/time strings in these formats (and only these): 688;; 689;; YYYY-MM-DD([ T]hh:mm:ss)?([,.]n+)?([+-]hh:mm)? 690;; YYYY-MM-DD([ T]hh:mm:ss)?([,.]n+)?([+-]hhmm)? 691;; YYYY-MM-DD([ T]hh:mm:ss)?([,.]n+)?([+-]hh)? 692;; YYYY-MM-DD([ T]hh:mm:ss)?([,.]n+)?[Z]? 693;; 694;; where (...)? indicates an optional group (occurs zero or one times) 695;; ...+ indicates one or more instances of ..., 696;; and [...] indicates literal character alternatives. 697;; 698;; Note that the nregex package doesn't handle optional groups or ...+. 699;; The notation above is only for describing the behavior of the parser. 700;; 701;; Trailing unparsed stuff causes the parser to fail (return NIL). 702 703(defun match-date-yyyy-mm-dd (s) (funcall #.(maxima-nregex::regex-compile "^([0-9][0-9][0-9][0-9])-([0-9][0-9])-([0-9][0-9])") s)) 704(defun match-time-hh-mm-ss (s) (funcall #.(maxima-nregex::regex-compile "^[ T]([0-9][0-9]):([0-9][0-9]):([0-9][0-9])") s)) 705(defun match-fraction-nnn (s) (funcall #.(maxima-nregex::regex-compile "^[,.]([0-9][0-9]*)") s)) 706(defun match-tz-hh-mm (s) (funcall #.(maxima-nregex::regex-compile "^([+-])([0-9][0-9]):([0-9][0-9])$") s)) 707(defun match-tz-hhmm (s) (funcall #.(maxima-nregex::regex-compile "^([+-])([0-9][0-9])([0-9][0-9])$") s)) 708(defun match-tz-hh (s) (funcall #.(maxima-nregex::regex-compile "^([+-])([0-9][0-9])$") s)) 709(defun match-tz-Z (s) (funcall #.(maxima-nregex::regex-compile "^Z$") s)) 710 711(defmfun $parse_timedate (s) 712 (setq s (string-trim '(#\Space #\Tab #\Newline #\Return) s)) 713 (let (year month day 714 (hours 0) (minutes 0) (seconds 0) 715 (seconds-fraction 0) seconds-fraction-numerator tz) 716 (if (match-date-yyyy-mm-dd s) 717 (progn 718 (multiple-value-setq (year month day) (extract-groups-integers s)) 719 (setq s (subseq s (second (aref maxima-nregex::*regex-groups* 0))))) 720 (return-from $parse_timedate nil)) 721 (when (match-time-hh-mm-ss s) 722 (multiple-value-setq (hours minutes seconds) (extract-groups-integers s)) 723 (setq s (subseq s (second (aref maxima-nregex::*regex-groups* 0))))) 724 (when (match-fraction-nnn s) 725 (multiple-value-setq (seconds-fraction-numerator) (extract-groups-integers s)) 726 (let ((group1 (aref maxima-nregex::*regex-groups* 1))) 727 (setq seconds-fraction (div seconds-fraction-numerator (expt 10 (- (second group1) (first group1)))))) 728 (setq s (subseq s (second (aref maxima-nregex::*regex-groups* 0))))) 729 (cond 730 ((match-tz-hh-mm s) 731 (multiple-value-bind (tz-sign tz-hours tz-minutes) (extract-groups-integers s) 732 (setq tz (* tz-sign (+ tz-hours (/ tz-minutes 60)))))) 733 ((match-tz-hhmm s) 734 (multiple-value-bind (tz-sign tz-hours tz-minutes) (extract-groups-integers s) 735 (setq tz (* tz-sign (+ tz-hours (/ tz-minutes 60)))))) 736 ((match-tz-hh s) 737 (multiple-value-bind (tz-sign tz-hours) (extract-groups-integers s) 738 (setq tz (* tz-sign tz-hours)))) 739 ((match-tz-Z s) 740 (setq tz 0)) 741 (t 742 (if (> (length s) 0) 743 (return-from $parse_timedate nil)))) 744 745 (encode-time-with-all-parts year month day hours minutes seconds seconds-fraction (if tz (- tz))))) 746 747(defun extract-groups-integers (s) 748 (let ((groups (coerce (subseq maxima-nregex::*regex-groups* 1 maxima-nregex::*regex-groupings*) 'list))) 749 (values-list (mapcar #'parse-integer-or-sign 750 (mapcar #'(lambda (ab) (subseq s (first ab) (second ab))) 751 groups))))) 752 753(defun parse-integer-or-sign (s) 754 (cond 755 ((string= s "+") 1) 756 ((string= s "-") -1) 757 (t (parse-integer s)))) 758 759; Clisp (2.49) / Windows does have a problem with dates before 1970-01-01, 760; therefore add 400 years in that case and subtract 12622780800 761; (= parse_timedate("2300-01-01Z") (Lisp starts with 1900-01-01) in timezone 762; GMT) afterwards. 763; see discussion on mailing list circa 2015-04-21: "parse_timedate error" 764; 765; Nota bene that this approach is correct only if the daylight saving time flag 766; is the same for the given date and date + 400 years. That is true for 767; dates before 1970-01-01 and after 2038-01-18, for Clisp at least, 768; which ignores daylight saving time for all dates in those ranges, 769; effectively making them all standard time. 770 771#+(and clisp win32) 772(defun encode-time-with-all-parts (year month day hours minutes seconds-integer seconds-fraction tz) 773 ;; Experimenting with Clisp 2.49 for Windows seems to show that the bug 774 ;; is triggered when local time zone is east of UTC, for times before 775 ;; 1970-01-01 00:00:00 UTC + the number of hours of the time zone. 776 ;; So apply the bug workaround to all times < 1970-01-02. 777 (if (or (< year 1970) (and (= year 1970) (= day 1))) 778 (sub (encode-time-with-all-parts (add year 400) month day hours minutes seconds-integer seconds-fraction tz) 12622780800) 779 (add seconds-fraction 780 ;; Some Lisps allow TZ to be null but CLHS doesn't explicitly allow it, 781 ;; so work around null TZ here. 782 (if tz 783 (encode-universal-time seconds-integer minutes hours day month year tz) 784 (encode-universal-time seconds-integer minutes hours day month year))))) 785 786#-(and clisp win32) 787(defun encode-time-with-all-parts (year month day hours minutes seconds-integer seconds-fraction tz) 788 (add seconds-fraction 789 ;; Some Lisps allow TZ to be null but CLHS doesn't explicitly allow it, 790 ;; so work around null TZ here. 791 (if tz 792 (encode-universal-time seconds-integer minutes hours day month year tz) 793 (encode-universal-time seconds-integer minutes hours day month year)))) 794 795(defmfun $encode_time (year month day hours minutes seconds &optional tz-offset) 796 (when tz-offset 797 (setq tz-offset (sub 0 tz-offset)) 798 (cond 799 ((and (consp tz-offset) (eq (caar tz-offset) 'rat)) 800 (setq tz-offset (/ (second tz-offset) (third tz-offset)))) 801 ((floatp tz-offset) 802 (setq tz-offset (rationalize tz-offset)))) 803 (setq tz-offset (/ (round tz-offset 1/3600) 3600))) 804 (let* 805 ((seconds-integer (mfuncall '$floor seconds)) 806 (seconds-fraction (sub seconds seconds-integer))) 807 (encode-time-with-all-parts year month day hours minutes seconds-integer seconds-fraction tz-offset))) 808 809(defmfun $decode_time (seconds &optional tz) 810 (cond 811 ((and (consp tz) (eq (caar tz) 'rat)) 812 (setq tz (/ (second tz) (third tz)))) 813 ((floatp tz) 814 (setq tz (rationalize tz)))) 815 (if tz (setq tz (/ (round tz 1/3600) 3600))) 816 (let* 817 ((seconds-integer (mfuncall '$floor seconds)) 818 (seconds-fraction (sub seconds seconds-integer))) 819 (multiple-value-bind 820 (seconds minutes hours day month year day-of-week dst-p tz) 821 ;; Some Lisps allow TZ to be null but CLHS doesn't explicitly allow it, 822 ;; so work around null TZ here. 823 (if tz (decode-universal-time seconds-integer (- tz)) 824 (decode-universal-time seconds-integer)) 825 (declare (ignore day-of-week #+gcl dst-p)) 826 ;; HMM, CAN DECODE-UNIVERSAL-TIME RETURN TZ = NIL ?? 827 (let ((tz-offset 828 #-gcl (if dst-p (- 1 tz) (- tz)) 829 #+gcl (- tz) ; bug in gcl https://savannah.gnu.org/bugs/?50570 830 )) 831 (list '(mlist) year month day hours minutes (add seconds seconds-fraction) ($ratsimp tz-offset)))))) 832 833;;Some systems make everything functionp including macros: 834(defun functionp (x) 835 (cond ((symbolp x) 836 (and (not (macro-function x)) 837 (fboundp x) t)) 838 ((cl:functionp x)))) 839 840;; These symbols are shadowed because we use them also as special 841;; variables. 842(deff break #'cl:break) 843(deff gcd #'cl:gcd) 844 845#+(and sbcl sb-package-locks) 846(defun makunbound (sym) 847 (sb-ext:without-package-locks 848 (cl:makunbound sym))) 849