Menu
▾
▴
[Matlisp-commit] [matlisp-git]matlisp branch tensor updated. 2012-02-23-88-g1d9d45b
|
From: Akshay S. <ak...@us...> - 2012-05-29 18:14:20
|
This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "matlisp".
The branch, tensor has been updated
via 1d9d45b7aac05a33ccb3cae5428a08cda19d00ce (commit)
via b7491a45a621cf8b4d5c266ec39a8850172d2f02 (commit)
via f9871bd640672b300b2b1790671f16694a67c184 (commit)
via a1fba66076d96b9abe83d35ac2780be0fc363e1c (commit)
via d19ddc6fed6d674cc555e2911c3a8a44334a0c20 (commit)
from 365629a9b8ca20f729635ec74047904caca9c8d9 (commit)
Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.
- Log -----------------------------------------------------------------
commit 1d9d45b7aac05a33ccb3cae5428a08cda19d00ce
Author: Akshay Srinivasan <aks...@gm...>
Date: Tue May 29 22:55:53 2012 +0530
Added Mark-Kantrovitz' infix package - stolen from femlisp.
diff --git a/infix/infix.asd b/infix/infix.asd
new file mode 100644
index 0000000..1730a75
--- /dev/null
+++ b/infix/infix.asd
@@ -0,0 +1,7 @@
+;;;; -*- Mode: Lisp; Package: User; -*-
+
+(defpackage #:infix-system (:use #:asdf #:cl))
+(in-package #:infix-system)
+
+(defsystem infix
+ :components ((:file "src")))
diff --git a/infix/src.lisp b/infix/src.lisp
new file mode 100644
index 0000000..45de827
--- /dev/null
+++ b/infix/src.lisp
@@ -0,0 +1,1102 @@
+;;; Wed Jan 18 13:13:59 1995 by Mark Kantrowitz <mk...@FL...>
+;;; infix.cl -- 40545 bytes
+
+;;; **************************************************************************
+;;; Infix ********************************************************************
+;;; **************************************************************************
+;;;
+;;; This is an implementation of an infix reader macro. It should run in any
+;;; valid Common Lisp and has been tested in Allegro CL 4.1, Lucid CL 4.0.1,
+;;; MCL 2.0 and CMU CL. It allows the user to type arithmetic expressions in
+;;; the traditional way (e.g., 1+2) when writing Lisp programs instead of
+;;; using the normal Lisp syntax (e.g., (+ 1 2)). It is not intended to be a
+;;; full replacement for the normal Lisp syntax. If you want a more complete
+;;; alternate syntax for Lisp, get a copy Apple's MLisp or Pratt's CGOL.
+;;;
+;;; Although similar in concept to the Symbolics infix reader (#<DIAMOND>),
+;;; no real effort has been made to ensure compatibility beyond coverage
+;;; of at least the same set of basic arithmetic operators. There are several
+;;; differences in the syntax beyond just the choice of #I as the macro
+;;; character. (Our syntax is a little bit more C-like than the Symbolics
+;;; macro in addition to some more subtle differences.)
+;;;
+;;; We initially chose $ as a macro character because of its association
+;;; with mathematics in LaTeX, but unfortunately that character is already
+;;; used in MCL. We switched to #I() because it was one of the few options
+;;; remaining.
+;;;
+;;; Written by Mark Kantrowitz, School of Computer Science,
+;;; Carnegie Mellon University, March 1993.
+;;;
+;;; Copyright (c) 1993 by Mark Kantrowitz. All rights reserved.
+;;;
+;;; Use and copying of this software and preparation of derivative works
+;;; based upon this software are permitted, so long as the following
+;;; conditions are met:
+;;; o no fees or compensation are charged for use, copies,
+;;; distribution or access to this software
+;;; o this copyright notice is included intact.
+;;; This software is made available AS IS, and no warranty is made about
+;;; the software or its performance.
+;;;
+;;; In no event will the author(s) or their institutions be liable to you for
+;;; damages, including lost profits, lost monies, or other special, incidental
+;;; or consequential damages, arising out of or in connection with the use or
+;;; inability to use (including but not limited to loss of data or data being
+;;; rendered inaccurate or losses sustained by third parties or a failure of
+;;; the program to operate as documented) the program, or for any claim by
+;;; any other party, whether in an action of contract, negligence, or
+;;; other tortious action.
+;;;
+;;; Please send bug reports, comments and suggestions to mk...@cs....
+;;;
+;;; The current version of this software and a variety of related utilities
+;;; may be obtained from the Lisp Repository by anonymous ftp
+;;; from ftp.cs.cmu.edu [128.2.206.173] in the directory
+;;; user/ai/lang/lisp/code/syntax/infix/
+;;; If your site runs the Andrew File System, you can cd to the AFS directory
+;;; /afs/cs.cmu.edu/project/ai-repository/ai/lang/lisp/code/syntax/infix/
+;;;
+;;; If you wish to be added to the Lis...@cs... mailing list,
+;;; send email to Lis...@cs... with your name, email
+;;; address, and affiliation. This mailing list is primarily for
+;;; notification about major updates, bug fixes, and additions to the Lisp
+;;; Utilities Repository. The mailing list is intended to have low traffic.
+;;;
+
+;;; ********************************
+;;; Documentation ******************
+;;; ********************************
+;;;
+;;; Syntax:
+;;;
+;;; Begin the reader macro with #I( and end it with ). For example,
+;;; #I( x^^2 + y^^2 )
+;;; is equivalent to the Lisp form
+;;; (+ (expt x 2) (expt y 2))
+;;; but much easier to read according to some folks.
+;;;
+;;; If you want to see the expansion, type a quote before the #I form
+;;; at the Lisp prompt:
+;;; > '#I(if x<y<=z then f(x)=x^^2+y^^2 else f(x)=x^^2-y^^2)
+;;; (IF (AND (< X Y) (<= Y Z))
+;;; (SETF (F X) (+ (EXPT X 2) (EXPT Y 2)))
+;;; (SETF (F X) (- (EXPT X 2) (EXPT Y 2))))
+;;;
+;;;
+;;; Operators:
+;;;
+;;; NOTE: == is equality, = is assignment (C-style).
+;;;
+;;; \ quoting character: x\-y --> x-y
+;;; ! lisp escape !(foo bar) --> (foo bar)
+;;; ; comment
+;;; x = y assignment (setf x y)
+;;; x += y increment (incf x y)
+;;; x -= y decrement (decf x y)
+;;; x *= y multiply and store (setf x (* x y))
+;;; x /= y divide and store (setf x (/ x y))
+;;; x|y bitwise logical inclusive or (logior x y)
+;;; x^y bitwise logical exclusive or (logxor x y)
+;;; x&y bitwise logical and (logand x y)
+;;; x<<y left shift (ash x y)
+;;; x>>y right shift (ash x (- y))
+;;; ~x ones complement (unary) (lognot x)
+;;; x and y conjunction (and x y)
+;;; x && y conjunction (and x y)
+;;; x or y disjunction (or x y)
+;;; x || y disjunction (or x y)
+;;; not x negation (not x)
+;;; x^^y exponentiation (expt x y)
+;;; x,y sequence (progn x y)
+;;; (x,y) sequence (progn x y)
+;;; also parenthesis (x+y)/z --> (/ (+ x y) z)
+;;; f(x,y) functions (f x y)
+;;; a[i,j] array reference (aref a i j)
+;;; x+y x*y arithmetic (+ x y) (* x y)
+;;; x-y x/y arithmetic (- x y) (/ x y)
+;;; -y value negation (- y)
+;;; x % y remainder (mod x y)
+;;; x<y x>y inequalities (< x y) (> x y)
+;;; x <= y x >= y inequalities (<= x y) (>= x y)
+;;; x == y equality (= x y)
+;;; x != y equality (not (= x y))
+;;; if p then q conditional (when p q)
+;;; if p then q else r conditional (if p q r)
+;;;
+
+;;; Precedence:
+;;;
+;;; The following precedence conventions are obeyed by the infix operators:
+;;; [ ( !
+;;; ^^
+;;; ~
+;;; * / %
+;;; + -
+;;; << >>
+;;; < == > <= != >=
+;;; &
+;;; ^
+;;; |
+;;; not
+;;; and
+;;; or
+;;; = += -= *= /=
+;;; ,
+;;; if
+;;; then else
+;;; ] )
+;;;
+;;; Note that logical negation has lower precedence than numeric comparison
+;;; so that "not a<b" becomes (not (< a b)), which is different from the
+;;; C precedence conventions. You can change the precedence conventions by
+;;; modifying the value of the variable *operator-ordering*.
+;;;
+
+;;; ********************************
+;;; To Do **************************
+;;; ********************************
+;;;
+;;; Write some more test cases.
+;;; Write some more syntactic optimizations.
+;;; Would really like ~x to be (not x), but need it for (lognot x).
+;;; Support for multiple languages, such as a Prolog parser, a
+;;; strictly C compatible parser, etc.
+
+;;; Create a more declarative format, where there is one big table of
+;;; operators with all the info on them, and also NOT have the list of
+;;; operators in the comment, where they are likely to become wrong when
+;;; changes are made to the code. For example, something like:
+
+;; (define-infix-operators
+;; ([ 30 :matchfix aref :end ])
+;; (* 20 :infix * )
+;; (+ 10 :infix + :prefix + )
+;; (& 10 :infix and )
+;; (+= 10 :infix #'+=-operator )
+;; ...)
+
+
+;;; ********************************
+;;; Change Log *********************
+;;; ********************************
+;;;
+;;; 9-MAR-93 mk Created
+;;; 12-MAR-93 mk Fixed defpackage form for Lucid.
+;;; 1.1:
+;;; 14-OCT-93 mk Changed macro character from #$ to #I(). Suggested by
+;;; Scott McKay.
+;;; 1.2:
+;;; 18-JAN-95 norvig Added *print-infix-copyright*, string->prefix, support
+;;; for #I"..." in addition to #i(...) which lets one
+;;; type #i"a|b" which doesn't confuse editors that aren't
+;;; |-aware. Also added := as a synonym for =, so that
+;;; '#i"car(a) := b" yields (SETF (CAR A) B).
+;;;
+;;; 1.3:
+;;; 28-JUN-96 mk Modified infix reader to allow whitespace between the #I
+;;; and the start of the expression.
+
+
+
+;;; ********************************
+;;; Implementation Notes ***********
+;;; ********************************
+;;;
+;;; Initially we tried implementing everything within the Lisp reader,
+;;; but found this to not be workable. Parameters had to be passed in
+;;; global variables, and some of the processing turned out to be
+;;; indelible, so it wasn't possible to use any kind of lookahead.
+;;; Center-embedded constructions were also a problem, due to the lack
+;;; of an explicit stack.
+;;;
+;;; So we took another tack, that used below. The #I macro binds the
+;;; *readtable* to a special readtable, which is used solely for tokenization
+;;; of the input. Then the problem is how to correctly parenthesize the input.
+;;; We do that with what is essentially a recursive-descent parser. An
+;;; expression is either a prefix operator followed by an expression, or an
+;;; expression followed by an infix operator followed by an expression. When
+;;; the latter expression is complex, the problem becomes a little tricky.
+;;; For example, suppose we have
+;;; exp1 op1 exp2 op2
+;;; We need to know whether to parenthesize it as
+;;; (exp1 op1 exp2) op2
+;;; or as
+;;; exp1 op1 (exp2 op2 ...)
+;;; The second case occurs either when op2 has precedence over op1 (e.g.,
+;;; * has precedence over +) or op2 and op1 are the same right-associative
+;;; operator (e.g., exponentiation). Thus the algorithm is as follows:
+;;; When we see op1, we want to gobble up exp2 op2 exp3 op3 ... opn expn+1
+;;; into an expression where op2 through opn all have higher precedence
+;;; than op1 (or are the same right-associative operator), and opn+1 doesn't.
+;;; This algorithm is implemented by the GATHER-SUPERIORS function.
+;;;
+;;; Because + and - are implemented in the infix readtable as terminating
+;;; macro cahracters, the exponentiation version of Lisp number syntax
+;;; 1e-3 == 0.001
+;;; doesn't work correctly -- it parses it as (- 1e 3). So we add a little
+;;; cleverness to GATHER-SUPERIORS to detect when the tokenizer goofed.
+;;; Since this requires the ability to lookahead two tokens, we use a
+;;; stack to implement the lookahead in PEEK-TOKEN and READ-TOKEN.
+;;;
+;;; Finally, the expression returned by GATHER-SUPERIORS sometimes needs to
+;;; be cleaned up a bit. For example, parsing a<b<c would normally return
+;;; (< (< a b) c), which obviously isn't correct. So POST-PROCESS-EXPRESSION
+;;; detects this and similar cases, replacing the expression with (< a b c).
+;;; For cases like a<b<=c, it replaces it with (and (< a b) (<= b c)).
+;;;
+
+;;; ********************************
+;;; Package Cruft ******************
+;;; ********************************
+
+(defpackage #:infix (:use #-:lucid #:common-lisp
+ #+:lucid "LISP" #+:lucid "LUCID-COMMON-LISP")
+ (:export #:test-infix #:string->prefix))
+
+(in-package #:infix)
+
+(pushnew :infix *features*)
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (defparameter *version* "1.3 28-JUN-96")
+ (defparameter *print-infix-copyright* t
+ "If non-NIL, prints a copyright notice upon loading this file.")
+
+ (defun infix-copyright (&optional (stream *standard-output*))
+ "Prints an INFIX copyright notice and header upon startup."
+ (format stream "~%;;; ~V,,,'*A" 73 "*")
+ (format stream "~%;;; Infix notation for Common Lisp.")
+ (format stream "~%;;; Version ~A." *version*)
+ (format stream "~%;;; Written by Mark Kantrowitz, ~
+ CMU School of Computer Science.")
+ (format stream "~%;;; Copyright (c) 1993-95. All rights reserved.")
+ (format stream "~%;;; May be freely redistributed, provided this ~
+ notice is left intact.")
+ (format stream "~%;;; This software is made available AS IS, without ~
+ any warranty.")
+ (format stream "~%;;; ~V,,,'*A~%" 73 "*")
+ (force-output stream))
+
+ ;; What this means is you can either turn off the copyright notice
+ ;; by setting the parameter, or you can turn it off by including
+ ;; (setf (get :infix :dont-print-copyright) t) in your lisp init file.
+ (when (and *print-infix-copyright*
+ (not (get :infix :dont-print-copyright)))
+ (infix-copyright)))
+
+;;; ********************************
+;;; Readtable **********************
+;;; ********************************
+
+(defparameter *infix-readtable* (copy-readtable nil))
+(defparameter *normal-readtable* (copy-readtable nil))
+
+(defmacro infix-error (format-string &rest args)
+ `(let ((*readtable* *normal-readtable*))
+ (error ,format-string ,@args)))
+
+(defun infix-reader (stream subchar arg)
+ ;; Read either #I(...) or #I"..."
+ (declare (ignore arg subchar))
+ (let ((first-char (peek-char nil stream t nil t)))
+ (cond ((char= first-char #\space)
+ (read-char stream) ; skip over whitespace
+ (infix-reader stream nil nil))
+ ((char= first-char #\")
+ ;; Read double-quote-delimited infix expressions.
+ (string->prefix (read stream t nil t)))
+ ((char= first-char #\()
+ (read-char stream) ; get rid of opening left parenthesis
+ (let ((*readtable* *infix-readtable*)
+ (*normal-readtable* *readtable*))
+ (read-infix stream)))
+ (t
+ (infix-error "Infix expression starts with ~A" first-char)))))
+
+(set-dispatch-macro-character #\# #\I #'infix-reader *readtable*) ; was #\# #\$
+
+(defun string->prefix (string)
+ "Convert a string to a prefix s-expression using the infix reader.
+ If the argument is not a string, just return it as is."
+ (if (stringp string)
+ (with-input-from-string (stream (concatenate 'string "#I(" string ")"))
+ (read stream))
+ string))
+
+(defun read-infix (stream)
+ (let* ((result (gather-superiors '\) stream)) ; %infix-end-token%
+ (next-token (read-token stream)))
+ (unless (same-token-p next-token '\)) ; %infix-end-token%
+ (infix-error "Infix expression ends with ~A." next-token))
+ result))
+
+(defun read-regular (stream)
+ (let ((*readtable* *normal-readtable*))
+ (read stream t nil t)))
+
+
+;;; ********************************
+;;; Reader Code ********************
+;;; ********************************
+
+(defun same-operator-p (x y)
+ (same-token-p x y))
+
+(defun same-token-p (x y)
+ (and (symbolp x)
+ (symbolp y)
+ (string-equal (symbol-name x) (symbol-name y))))
+
+;;; Peeking Token Reader
+
+(defvar *peeked-token* nil)
+(defun read-token (stream)
+ (if *peeked-token*
+ (pop *peeked-token*)
+ (read stream t nil t)))
+(defun peek-token (stream)
+ (unless *peeked-token*
+ (push (read stream t nil t) *peeked-token*))
+ (car *peeked-token*))
+
+;;; Hack to work around + and - being terminating macro characters,
+;;; so 1e-3 doesn't normally work correctly.
+
+(defun fancy-number-format-p (left operator stream)
+ (when (and (symbolp left)
+ (find operator '(+ -) :test #'same-operator-p))
+ (let* ((name (symbol-name left))
+ (length (length name)))
+ (when (and (valid-numberp (subseq name 0 (1- length)))
+ ;; Exponent, Single, Double, Float, or Long
+ (find (subseq name (1- length))
+ '("e" "s" "d" "f" "l")
+ :test #'string-equal))
+ (read-token stream)
+ (let ((right (peek-token stream)))
+ (cond ((integerp right)
+ ;; it is one of the fancy numbers, so return it
+ (read-token stream)
+ (let ((*readtable* *normal-readtable*))
+ (read-from-string (format nil "~A~A~A"
+ left operator right))))
+ (t
+ ;; it isn't one of the fancy numbers, so unread the token
+ (push operator *peeked-token*)
+ ;; and return nil
+ nil)))))))
+
+(defun valid-numberp (string)
+ (let ((saw-dot nil))
+ (dolist (char (coerce string 'list) t)
+ (cond ((char= char #\.)
+ (if saw-dot
+ (return nil)
+ (setq saw-dot t)))
+ ((not (find char "01234567890" :test #'char=))
+ (return nil))))))
+
+;;; Gobbles an expression from the stream.
+
+(defun gather-superiors (previous-operator stream)
+ "Gathers an expression whose operators all exceed the precedence of
+ the operator to the left."
+ (let ((left (get-first-token stream)))
+ (loop
+ (setq left (post-process-expression left))
+ (let ((peeked-token (peek-token stream)))
+ (let ((fancy-p (fancy-number-format-p left peeked-token stream)))
+ (when fancy-p
+ ;; i.e., we've got a number like 1e-3 or 1e+3 or 1f-1
+ (setq left fancy-p
+ peeked-token (peek-token stream))))
+ (unless (or (operator-lessp previous-operator peeked-token)
+ (and (same-operator-p peeked-token previous-operator)
+ (operator-right-associative-p previous-operator)))
+ ;; The loop should continue when the peeked operator is
+ ;; either superior in precedence to the previous operator,
+ ;; or the same operator and right-associative.
+ (return left)))
+ (setq left (get-next-token stream left)))))
+
+(defun get-first-token (stream)
+ (let ((token (read-token stream)))
+ (if (token-operator-p token)
+ ;; It's an operator in a prefix context.
+ (apply-token-prefix-operator token stream)
+ ;; It's a regular token
+ token)))
+
+(defun apply-token-prefix-operator (token stream)
+ (let ((operator (get-token-prefix-operator token)))
+ (if operator
+ (funcall operator stream)
+ (infix-error "~A is not a prefix operator" token))))
+
+(defun get-next-token (stream left)
+ (let ((token (read-token stream)))
+ (apply-token-infix-operator token left stream)))
+
+(defun apply-token-infix-operator (token left stream)
+ (let ((operator (get-token-infix-operator token)))
+ (if operator
+ (funcall operator stream left)
+ (infix-error "~A is not an infix operator" token))))
+
+;;; Fix to read-delimited-list so that it works with tokens, not
+;;; characters.
+
+(defun infix-read-delimited-list (end-token delimiter-token stream)
+ (do ((next-token (peek-token stream) (peek-token stream))
+ (list nil))
+ ((same-token-p next-token end-token)
+ ;; We've hit the end. Remove the end-token from the stream.
+ (read-token stream)
+ ;; and return the list of tokens.
+ ;; Note that this does the right thing with [] and ().
+ (nreverse list))
+ ;; Ignore the delimiters.
+ (when (same-token-p next-token delimiter-token)
+ (read-token stream))
+ ;; Gather the expression until the next delimiter.
+ (push (gather-superiors delimiter-token stream) list)))
+
+
+;;; ********************************
+;;; Precedence *********************
+;;; ********************************
+
+(defparameter *operator-ordering*
+ '(( \[ \( \! ) ; \[ is array reference
+ ( ^^ ) ; exponentiation
+ ( ~ ) ; lognot
+ ( * / % ) ; % is mod
+ ( + - )
+ ( << >> )
+ ( < == > <= != >= )
+ ( & ) ; logand
+ ( ^ ) ; logxor
+ ( \| ) ; logior
+ ( not )
+ ( and )
+ ( or )
+ ;; Where should setf and friends go in the precedence?
+ ( = |:=| += -= *= /= )
+ ( \, ) ; progn (statement delimiter)
+ ( if )
+ ( then else )
+ ( \] \) )
+ ( %infix-end-token% )) ; end of infix expression
+ "Ordered list of operators of equal precedence.")
+
+(defun operator-lessp (op1 op2)
+ (dolist (ops *operator-ordering* nil)
+ (cond ((find op1 ops :test #'same-token-p)
+ (return nil))
+ ((find op2 ops :test #'same-token-p)
+ (return t)))))
+
+(defparameter *right-associative-operators* '(^^ =))
+(defun operator-right-associative-p (operator)
+ (find operator *right-associative-operators*))
+
+
+;;; ********************************
+;;; Define Operators ***************
+;;; ********************************
+
+(defvar *token-operators* nil)
+(defvar *token-prefix-operator-table* (make-hash-table))
+(defvar *token-infix-operator-table* (make-hash-table))
+(defun token-operator-p (token)
+ (find token *token-operators*))
+(defun get-token-prefix-operator (token)
+ (gethash token *token-prefix-operator-table*))
+(defun get-token-infix-operator (token)
+ (gethash token *token-infix-operator-table*))
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (defmacro define-token-operator (operator-name &key
+ (prefix nil prefix-p)
+ (infix nil infix-p))
+ `(progn
+ (pushnew ',operator-name *token-operators*)
+ ,(when prefix-p
+ `(setf (gethash ',operator-name *token-prefix-operator-table*)
+ #'(lambda (stream)
+ ,@(cond ((and (consp prefix)
+ (eq (car prefix) 'infix-error))
+ ;; To avoid ugly compiler warnings.
+ `((declare (ignore stream))
+ ,prefix))
+ (t
+ (list prefix))))))
+ ,(when infix-p
+ `(setf (gethash ',operator-name *token-infix-operator-table*)
+ #'(lambda (stream left)
+ ,@(cond ((and (consp infix)
+ (eq (car infix) 'infix-error))
+ ;; To avoid ugly compiler warnings.
+ `((declare (ignore stream left))
+ ,infix))
+ (t
+ (list infix)))))))))
+
+;;; Readtable definitions for characters, so that the right token is returned.
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (defmacro define-character-tokenization (char function)
+ `(set-macro-character ,char ,function nil *infix-readtable*)))
+
+
+;;; ********************************
+;;; Operator Definitions ***********
+;;; ********************************
+
+(define-token-operator and
+ :infix `(and ,left ,(gather-superiors 'and stream)))
+(define-token-operator or
+ :infix `(or ,left ,(gather-superiors 'or stream)))
+(define-token-operator not
+ :prefix `(not ,(gather-superiors 'not stream)))
+
+(define-token-operator if
+ :prefix (let* ((test (gather-superiors 'if stream))
+ (then (cond ((same-token-p (peek-token stream) 'then)
+ (read-token stream)
+ (gather-superiors 'then stream))
+ (t
+ (infix-error "Missing THEN clause."))))
+ (else (when (same-token-p (peek-token stream) 'else)
+ (read-token stream)
+ (gather-superiors 'else stream))))
+ (cond ((and test then else)
+ `(if ,test ,then ,else))
+ ((and test then)
+ ;; no else clause
+ `(when ,test ,then))
+ ((and test else)
+ ;; no then clause
+ `(unless ,test ,else))
+ (t
+ ;; no then and else clauses --> always NIL
+ nil))))
+
+(define-token-operator then
+ :prefix (infix-error "THEN clause without an IF."))
+(define-token-operator else
+ :prefix (infix-error "ELSE clause without an IF."))
+
+(define-character-tokenization #\+
+ #'(lambda (stream char)
+ (declare (ignore char))
+ (cond ((char= (peek-char nil stream t nil t) #\=)
+ (read-char stream t nil t)
+ '+=)
+ (t
+ '+))))
+(define-token-operator +
+ :infix `(+ ,left ,(gather-superiors '+ stream))
+ :prefix (gather-superiors '+ stream))
+(define-token-operator +=
+ :infix `(incf ,left ,(gather-superiors '+= stream)))
+
+(define-character-tokenization #\-
+ #'(lambda (stream char)
+ (declare (ignore char))
+ (cond ((char= (peek-char nil stream t nil t) #\=)
+ (read-char stream t nil t)
+ '-=)
+ (t
+ '-))))
+(define-token-operator -
+ :infix `(- ,left ,(gather-superiors '- stream))
+ :prefix `(- ,(gather-superiors '- stream)))
+(define-token-operator -=
+ :infix `(decf ,left ,(gather-superiors '-= stream)))
+
+(define-character-tokenization #\*
+ #'(lambda (stream char)
+ (declare (ignore char))
+ (cond ((char= (peek-char nil stream t nil t) #\=)
+ (read-char stream t nil t)
+ '*=)
+ (t
+ '*))))
+(define-token-operator *
+ :infix `(* ,left ,(gather-superiors '* stream)))
+(define-token-operator *=
+ :infix `(,(if (symbolp left)
+ 'setq
+ 'setf)
+ ,left
+ (* ,left ,(gather-superiors '*= stream))))
+
+(define-character-tokenization #\/
+ #'(lambda (stream char)
+ (declare (ignore char))
+ (cond ((char= (peek-char nil stream t nil t) #\=)
+ (read-char stream t nil t)
+ '/=)
+ (t
+ '/))))
+(define-token-operator /
+ :infix `(/ ,left ,(gather-superiors '/ stream))
+ :prefix `(/ ,(gather-superiors '/ stream)))
+(define-token-operator /=
+ :infix `(,(if (symbolp left)
+ 'setq
+ 'setf)
+ ,left
+ (/ ,left ,(gather-superiors '/= stream))))
+
+(define-character-tokenization #\^
+ #'(lambda (stream char)
+ (declare (ignore char))
+ (cond ((char= (peek-char nil stream t nil t) #\^)
+ (read-char stream t nil t)
+ '^^)
+ (t
+ '^))))
+(define-token-operator ^^
+ :infix `(expt ,left ,(gather-superiors '^^ stream)))
+(define-token-operator ^
+ :infix `(logxor ,left ,(gather-superiors '^ stream)))
+
+(define-character-tokenization #\|
+ #'(lambda (stream char)
+ (declare (ignore char))
+ (cond ((char= (peek-char nil stream t nil t) #\|)
+ (read-char stream t nil t)
+ 'or)
+ (t
+ '\|))))
+(define-token-operator \|
+ :infix `(logior ,left ,(gather-superiors '\| stream)))
+
+(define-character-tokenization #\&
+ #'(lambda (stream char)
+ (declare (ignore char))
+ (cond ((char= (peek-char nil stream t nil t) #\&)
+ (read-char stream t nil t)
+ 'and)
+ (t
+ '\&))))
+(define-token-operator \&
+ :infix `(logand ,left ,(gather-superiors '\& stream)))
+
+(define-character-tokenization #\%
+ #'(lambda (stream char)
+ (declare (ignore stream char))
+ '\%))
+(define-token-operator \%
+ :infix `(mod ,left ,(gather-superiors '\% stream)))
+
+(define-character-tokenization #\~
+ #'(lambda (stream char)
+ (declare (ignore stream char))
+ '\~))
+(define-token-operator \~
+ :prefix `(lognot ,(gather-superiors '\~ stream)))
+
+(define-character-tokenization #\,
+ #'(lambda (stream char)
+ (declare (ignore stream char))
+ '\,))
+(define-token-operator \,
+ :infix `(progn ,left ,(gather-superiors '\, stream)))
+
+(define-character-tokenization #\=
+ #'(lambda (stream char)
+ (declare (ignore char))
+ (cond ((char= (peek-char nil stream t nil t) #\=)
+ (read-char stream t nil t)
+ '==)
+ (t
+ '=))))
+(define-token-operator ==
+ :infix `(= ,left ,(gather-superiors '== stream)))
+(define-token-operator =
+ :infix `(,(if (symbolp left)
+ 'setq
+ 'setf)
+ ,left
+ ,(gather-superiors '= stream)))
+
+(define-character-tokenization #\:
+ #'(lambda (stream char)
+ (declare (ignore char))
+ (cond ((char= (peek-char nil stream t nil t) #\=)
+ (read-char stream t nil t)
+ '|:=|)
+ (t
+ '|:|))))
+(define-token-operator |:=|
+ :infix `(,(if (symbolp left)
+ 'setq
+ 'setf)
+ ,left
+ ,(gather-superiors '|:=| stream)))
+
+(define-character-tokenization #\<
+ #'(lambda (stream char)
+ (declare (ignore char))
+ (cond ((char= (peek-char nil stream t nil t) #\=)
+ (read-char stream t nil t)
+ '<=)
+ ((char= (peek-char nil stream t nil t) #\<)
+ (read-char stream t nil t)
+ '<<)
+ (t
+ '<))))
+(define-token-operator <
+ :infix `(< ,left ,(gather-superiors '< stream)))
+(define-token-operator <=
+ :infix `(<= ,left ,(gather-superiors '<= stream)))
+(define-token-operator <<
+ :infix `(ash ,left ,(gather-superiors '<< stream)))
+
+(define-character-tokenization #\>
+ #'(lambda (stream char)
+ (declare (ignore char))
+ (cond ((char= (peek-char nil stream t nil t) #\=)
+ (read-char stream t nil t)
+ '>=)
+ ((char= (peek-char nil stream t nil t) #\>)
+ (read-char stream t nil t)
+ '>>)
+ (t
+ '>))))
+(define-token-operator >
+ :infix `(> ,left ,(gather-superiors '> stream)))
+(define-token-operator >=
+ :infix `(>= ,left ,(gather-superiors '>= stream)))
+(define-token-operator >>
+ :infix `(ash ,left (- ,(gather-superiors '>> stream))))
+
+(define-character-tokenization #\!
+ #'(lambda (stream char)
+ (declare (ignore char))
+ (cond ((char= (peek-char nil stream t nil t) #\=)
+ (read-char stream t nil t)
+ '!=)
+ (t
+ '!))))
+(define-token-operator !=
+ :infix `(not (= ,left ,(gather-superiors '!= stream))))
+(define-token-operator !
+ :prefix (read-regular stream))
+
+(define-character-tokenization #\[
+ #'(lambda (stream char)
+ (declare (ignore stream char))
+ '\[))
+(define-token-operator \[
+ :infix (let ((indices (infix-read-delimited-list '\] '\, stream)))
+ (if (null indices)
+ (infix-error "No indices found in array reference.")
+ `(aref ,left ,@indices))))
+
+(define-character-tokenization #\(
+ #'(lambda (stream char)
+ (declare (ignore stream char))
+ '\())
+(define-token-operator \(
+ :infix `(,left ,@(infix-read-delimited-list '\) '\, stream))
+ :prefix (let ((list (infix-read-delimited-list '\) '\, stream)))
+ (if (null (rest list))
+ ;; only one element in list. works correctly if list is NIL
+ (first list)
+ ;; several elements in list
+ `(progn ,@list))))
+
+(define-character-tokenization #\]
+ #'(lambda (stream char)
+ (declare (ignore stream char))
+ '\]))
+(define-token-operator \]
+ :infix (infix-error "Extra close brace \"]\" in infix expression"))
+
+(define-character-tokenization #\)
+ #'(lambda (stream char)
+ (declare (ignore stream char))
+ '\)))
+(define-token-operator \)
+ :infix (infix-error "Extra close paren \")\" in infix expression"))
+
+#|
+;;; Commented out because no longer using $ as the macro character.
+(define-character-tokenization #\$
+ #'(lambda (stream char)
+ (declare (ignore stream char))
+ '%infix-end-token%))
+(define-token-operator %infix-end-token%
+ :infix (infix-error "Prematurely terminated infix expression")
+ :prefix (infix-error "Prematurely terminated infix expression"))
+|#
+
+(define-character-tokenization #\;
+ #'(lambda (stream char)
+ (declare (ignore char))
+ (do ((char (peek-char nil stream t nil t)
+ (peek-char nil stream t nil t)))
+ ((or (char= char #\newline) (char= char #\return)
+ ;; was #\$
+; (char= char #\))
+ )
+ ;; Gobble characters until the end of the line or the
+ ;; end of the input.
+ (cond ((or (char= char #\newline) (char= char #\return))
+ (read-char stream)
+ (read stream t nil t))
+ (t
+ ;; i.e., return %infix-end-token%
+ (read stream t nil t))))
+ (read-char stream))))
+
+
+;;; ********************************
+;;; Syntactic Modifications ********
+;;; ********************************
+
+;;; Post processes the expression to remove some unsightliness caused
+;;; by the way infix processes the input. Note that it is also required
+;;; for correctness in the a<b<=c case.
+
+(defun post-process-expression (expression)
+ (if (and (consp expression)
+ (= (length expression) 3))
+ (destructuring-bind (operator left right) expression
+ (cond ((and (consp left)
+ (same-operator-p (first left) operator)
+ (find operator '(+ * / - and or < > <= >= progn)
+ :test #'same-operator-p))
+ ;; Flatten the expression if possible
+ (cond ((and (eq operator '-)
+ (= (length left) 2))
+ ;; -a-b --> (+ (- a) (- b)).
+ `(+ ,left (- ,right)))
+ ((and (eq operator '/)
+ (= (length left) 2))
+ ;; ditto with /
+ `(/ (* ,(second left) ,right)))
+ (t
+ ;; merges a+b+c as (+ a b c).
+ (append left (list right)))))
+ ((and (consp left)
+ (eq operator '-)
+ (eq (first left) '+))
+ ;; merges a+b-c as (+ a b (- c)).
+ (append left (list `(- ,right))))
+ ((and (consp left)
+ (find operator '(< > <= >=))
+ (find (first left) '(< > <= >=)))
+ ;; a<b<c --> a<b and b<c
+ `(and ,left
+ (,operator ,(first (last left))
+ ,right)))
+ (t
+ expression)))
+ expression))
+
+
+;;; ********************************
+;;; Test Infix *********************
+;;; ********************************
+
+;;; Invoke with (infix:test-infix).
+;;; Prints out all the tests that fail and a count of the number of failures.
+
+(defparameter *test-cases*
+ ;; Note that in strings, we have to slashify \ as \\.
+ '(("1 * +2" (* 1 2))
+ ("1 * -2" (* 1 (- 2)))
+ ("1 * /2" (* 1 (/ 2)))
+ ("/2" (/ 2))
+ ("not true" (not true))
+ ("foo\\-bar" foo-bar)
+ ("a + b-c" (+ a b (- c)))
+ ("a + b\\-c" (+ a b-c))
+ ("f\\oo" |FoO|)
+ ("!foo-bar * 2" (* foo-bar 2))
+ ("!(foo bar baz)" (foo bar baz))
+ ("!foo-bar " foo-bar)
+ ;; The following now longer gives an eof error, since the close
+ ;; parenthesis terminates the token.
+ ("!foo-bar" foo-bar) ; eof error -- ! eats the close $
+ ("a+-b" (+ a (- b)))
+ ("a+b" (+ a b))
+ ("a+b*c" (+ a (* b c)))
+ ("a+b+c" (+ a b c))
+ ("a+b-c" (+ a b (- c)))
+ ("a+b-c+d" (+ a b (- c) d))
+ ("a+b-c-d" (+ a b (- c) (- d)))
+ ("a-b" (- a b))
+ ("a*b" (* a b))
+ ("a*b*c" (* a b c))
+ ("a*b+c" (+ (* a b) c))
+ ("a/b" (/ a b))
+ ("a^^b" (expt a b))
+ ("foo/-bar" (/ foo (- bar)))
+ ("1+2*3^^4" (+ 1 (* 2 (expt 3 4))))
+ ("1+2*3^^4+5" (+ 1 (* 2 (expt 3 4)) 5))
+ ("2*3^^4+1" (+ (* 2 (expt 3 4)) 1))
+ ("2+3^^4*5" (+ 2 (* (expt 3 4) 5)))
+ ("2^^3^^4" (expt 2 (expt 3 4)))
+ ("x^^2 + y^^2" (+ (expt x 2) (expt y 2)))
+ ("(1+2)/3" (/ (+ 1 2) 3))
+ ("(a=b)" (setq a b))
+ ("(a=b,b=c)" (progn (setq a b) (setq b c)))
+ ("1*(2+3)" (* 1 (+ 2 3)))
+ ("1+2/3" (+ 1 (/ 2 3)))
+ ("a,b" (progn a b))
+ ("a,b,c" (progn a b c))
+ ("foo(a,b,(c,d))" (foo a b (progn c d)))
+ ("foo(a,b,c)" (foo a b c))
+ ("(a+b,c)" (progn (+ a b) c))
+ ("1" 1)
+ ("-1" (- 1))
+ ("+1" 1)
+ ("1." 1)
+ ("1.1" 1.1)
+ ("1e3" 1000.0)
+ ("1e-3" 0.001)
+ ("1f-3" 1f-3)
+ ("1e-3e" (- 1e 3e))
+ ("!1e-3 " 0.001)
+ ("a and b and c" (and a b c))
+ ("a and b or c" (or (and a b) c))
+ ("a and b" (and a b))
+ ("a or b and c" (or a (and b c)))
+ ("a or b" (or a b))
+ ("a<b and b<c" (and (< a b) (< b c)))
+ ("if (if a then b else c) then e" (when (if a b c) e))
+ ("if 1 then 2 else 3+4" (if 1 2 (+ 3 4)))
+ ("(if 1 then 2 else 3)+4" (+ (if 1 2 3) 4))
+ ("if a < b then b else a" (if (< a b) b a))
+ ("if a and b then c and d else e and f"
+ (if (and a b) (and c d) (and e f)))
+ ("if a or b then c or d else e or f" (if (or a b) (or c d) (or e f)))
+ ("if a then (if b then c else d) else e" (if a (if b c d) e))
+ ("if a then (if b then c) else d" (if a (when b c) d))
+ ("if a then b else c" (if a b c))
+ ("if a then b" (when a b))
+ ("if a then if b then c else d else e" (if a (if b c d) e))
+ ("if a then if b then c else d" (when a (if b c d)))
+ ("if if a then b else c then e" (when (if a b c) e))
+ ("if not a and not b then c" (when (and (not a) (not b)) c))
+ ("if not a then not b else not c and d"
+ (if (not a) (not b) (and (not c) d)))
+ ("not a and not b" (and (not a) (not b)))
+ ("not a or not b" (or (not a) (not b)))
+ ("not a<b and not b<c" (and (not (< a b)) (not (< b c))))
+ ("not a<b" (not (< a b)))
+ ("a[i,k]*b[j,k]" (* (aref a i k) (aref b j k)))
+ ("foo(bar)=foo[bar,baz]" (setf (foo bar) (aref foo bar baz)))
+ ("foo(bar,baz)" (foo bar baz))
+ ("foo[bar,baz]" (aref foo bar baz))
+ ("foo[bar,baz]=barf" (setf (aref foo bar baz) barf))
+ ("max = if a < b then b else a" (setq max (if (< a b) b a)))
+ ("a < b < c" (< A B C))
+ ("a < b <= c" (and (< a b) (<= b c)))
+ ("a <= b <= c" (<= A B C))
+ ("a <= b <= c" (<= A B C))
+ ("a!=b and b<c" (and (not (= a b)) (< b c)))
+ ("a!=b" (not (= a b)))
+ ("a<b" (< a b))
+ ("a==b" (= a b))
+ ("a*b(c)+d" (+ (* a (b c)) d))
+ ("a+b(c)*d" (+ a (* (b c) d)))
+ ("a+b(c)+d" (+ a (b c) d))
+ ("d+a*b(c)" (+ d (* a (b c))))
+ ("+a+b" (+ a b))
+ ("-a+b" (+ (- a) b))
+ ("-a-b" (+ (- a) (- b)))
+ ("-a-b-c" (+ (- a) (- b) (- c)))
+ ("a*b/c" (/ (* a b) c))
+ ("a+b-c" (+ a b (- c)))
+ ("a-b-c" (- a b c))
+ ("a/b*c" (* (/ a b) c))
+ ("a/b/c" (/ a b c))
+ ("/a/b" (/ (* a b)))
+ ("a^^b^^c" (expt a (expt b c)))
+ ("a(d)^^b^^c" (expt (a d) (expt b c)))
+ ("a<b+c<d" (< a (+ b c) d))
+ ("1*~2+3" (+ (* 1 (lognot 2)) 3))
+ ("1+~2*3" (+ 1 (* (lognot 2) 3)))
+ ("1+~2+3" (+ 1 (lognot 2) 3))
+ ("f(a)*=g(b)" (setf (f a) (* (f a) (g b))))
+ ("f(a)+=g(b)" (incf (f a) (g b)))
+ ("f(a)-=g(b)" (decf (f a) (g b)))
+ ("f(a)/=g(b)" (setf (f a) (/ (f a) (g b))))
+ ("a&b" (logand a b))
+ ("a^b" (logxor a b))
+ ("a|b" (logior a b))
+ ("a<<b" (ash a b))
+ ("a>>b" (ash a (- b)))
+ ("~a" (lognot a))
+ ("a&&b" (and a b))
+ ("a||b" (or a b))
+ ("a%b" (mod a b))
+
+ ;; Comment character -- must have carriage return after semicolon.
+ ("x^^2 ; the x coordinate
+ + y^^2 ; the y coordinate" :error)
+ ("x^^2 ; the x coordinate
+ + y^^2 ; the y coordinate
+ " (+ (expt x 2) (expt y 2)))
+
+ ;; Errors
+ ("foo(bar,baz" :error) ; premature termination
+ ;; The following no longer gives an error
+ ("foo(bar,baz))" (foo bar baz)) ; extra close parenthesis
+ ("foo[bar,baz]]" :error) ; extra close bracket
+ ("[foo,bar]" :error) ; AREF is not a prefix operator
+ ("and a" :error) ; AND is not a prefix operator
+ ("< a" :error) ; < is not a prefix operator
+ ("=bar" :error) ; SETF is not a prefix operator
+ ("*bar" :error) ; * is not a prefix operator
+ ("a not b" :error) ; NOT is not an infix operator
+ ("a if b then c" :error) ; IF is not an infix operator
+ ("" :error) ; premature termination (empty clause)
+ (")a" :error) ; left parent is not a prefix operator
+ ("]a" :error) ; left bracket is not a prefix operator
+ ))
+
+(defun test-infix (&optional (tests *test-cases*))
+ (let ((count 0))
+ (dolist (test tests)
+ (destructuring-bind (string result) test
+ (unless (test-infix-case string result)
+ (incf count))))
+ (format t "~&~:(~R~) test~p failed." count count)
+ (values)))
+
+(defun test-infix-case (string result)
+ (multiple-value-bind (value error)
+ (let ((*package* (find-package "INFIX")))
+ (ignore-errors
+ (values (read-from-string (concatenate 'string "#I(" string ")")
+ t nil))))
+ (cond (error
+ (cond ((eq result :error)
+ t)
+ (t
+ (format t "~&Test #I(~A) failed with ERROR." string)
+ nil)))
+ ((eq result :error)
+ (format t "~&Test #I(~A) failed. ~
+ ~& Expected ERROR ~
+ ~& but got ~A."
+ string value)
+ nil)
+ ((not (equal value result))
+ (format t "~&Test #I(~A) failed. ~
+ ~& Expected ~A ~
+ ~& but got ~A."
+ string result value)
+ nil)
+ (t
+ t))))
+
+;;; *EOF*
commit b7491a45a621cf8b4d5c266ec39a8850172d2f02
Author: Akshay Srinivasan <aks...@gm...>
Date: Wed May 23 10:10:33 2012 +0530
Moved blas-helper functions to a separate file.
Tensor-computation is not trivial!
diff --git a/src/blas-helpers.lisp b/src/blas-helpers.lisp
new file mode 100644
index 0000000..4869c2c
--- /dev/null
+++ b/src/blas-helpers.lisp
@@ -0,0 +1,39 @@
+(in-package :matlisp)
+
+(declaim (inline fortran-op))
+(defun fortran-op (op)
+ (ecase op (:n "N") (:t "T")))
+
+(declaim (inline fortran-nop))
+(defun fortran-nop (op)
+ (ecase op (:t "N") (:n "T")))
+
+(defun fortran-snop (sop)
+ (cond
+ ((string= sop "N") "T")
+ ((string= sop "T") "N")
+ (t (error "Unrecognised fortran-op."))))
+
+(defun blas-copyable-p (matrix)
+ (declare (optimize (safety 0) (speed 3))
+ (type (or real-matrix complex-matrix) matrix))
+ (mlet* ((nr (nrows matrix) :type fixnum)
+ (nc (ncols matrix) :type fixnum)
+ (rs (row-stride matrix) :type fixnum)
+ (cs (col-stride matrix) :type fixnum)
+ (ne (number-of-elements matrix) :type fixnum))
+ (cond
+ ((or (= nc 1) (= cs (* nr rs))) (values t rs ne))
+ ((or (= nr 1) (= rs (* nc cs))) (values t cs ne))
+ (t (values nil -1 -1)))))
+
+(defun blas-matrix-compatible-p (matrix &optional (op :n))
+ (declare (optimize (safety 0) (speed 3))
+ (type (or real-matrix complex-matrix) matrix))
+ (mlet* (((rs cs) (slot-values matrix '(row-stride col-stride))
+ :type (fixnum fixnum)))
+ (cond
+ ((= cs 1) (values :row-major rs (fortran-nop op)))
+ ((= rs 1) (values :col-major cs (fortran-op op)))
+ ;;Lets not confound lisp's type declaration.
+ (t (values nil -1 "?")))))
\ No newline at end of file
diff --git a/src/tensor-copy.lisp b/src/tensor-copy.lisp
new file mode 100644
index 0000000..f06e6a8
--- /dev/null
+++ b/src/tensor-copy.lisp
@@ -0,0 +1,36 @@
+(in-package :tensor)
+
+;;
+(defmacro generate-typed-copy!-func (func store-type matrix-type blas-func)
+ ;;Be very careful when using functions generated by this macro.
+ ;;Indexes can be tricky and this has no safety net
+ ;;Use only after checking the arguments for compatibility.
+ `(defun ,func (mat-a mat-b)
+ (declare (type ,matrix-type mat-a mat-b)
+ (optimize (safety 0) (speed 3)))
+ (mlet* (((cp-a inc-a sz-a) (blas-copyable-p mat-a) :type (boolean fixnum nil))
+ ((cp-b inc-b sz-b) (blas-copyable-p mat-b) :type (boolean fixnum nil))
+ ((hd-a st-a sz) (slot-values mat-a '(head store number-of-elements)) :type (fixnum (,store-type *) fixnum))
+ ((hd-b st-b) (slot-values mat-b '(head store)) :type (fixnum (,store-type *))))
+ (if (and cp-a cp-b)
+ (,blas-func sz st-a inc-a st-b inc-b :head-x hd-a :head-y hd-b)
+ (mlet* (((nr-a nc-a rs-a cs-a) (slot-values mat-a '(number-of-rows number-of-cols row-stride col-stride))
+ :type (fixnum fixnum fixnum fixnum))
+ ((rs-b cs-b) (slot-values mat-b '(row-stride col-stride))
+ :type (fixnum fixnum)))
+ ;;Choose the smaller of the loops
+ (when (> (nrows mat-a) (ncols mat-a))
+ (rotatef nr-a nc-a)
+ (rotatef rs-a cs-a)
+ (rotatef rs-b cs-b))
+ (loop for i from 0 below nr-a
+ do (,blas-func nc-a st-a cs-a st-b cs-b :head-x (+ hd-a (* i rs-a)) :head-y (+ hd-b (* i rs-b)))))))
+ mat-b))
+
+
+(defun real-typed-copy!-func (ten-a ten-b)
+
+
+
+(defun find-longest-chain (stds dims))
+
commit f9871bd640672b300b2b1790671f16694a67c184
Author: Akshay Srinivasan <aks...@gm...>
Date: Wed May 23 10:08:32 2012 +0530
Making standard-matrix a subclass of standard-tensor. Not complete yet.
diff --git a/packages.lisp b/packages.lisp
index d3af8bb..4134b4a 100644
--- a/packages.lisp
+++ b/packages.lisp
@@ -156,20 +156,15 @@
(defpackage :utilities
(:use :common-lisp)
(:export #:ensure-list
- #:zip
- #:zip-eq
- #:cut-cons-chain!
- #:when-let
- #:if-let
- #:if-ret
- #:get-arg
- #:nconsc
- #:with-gensyms
+ #:zip #:zip-eq
+ #:get-arg #:cut-cons-chain!
#:slot-values
- #:mlet*
#:recursive-append
- #:make-array-allocator
- ;;
+ ;;Macros
+ #:when-let #:if-let #:if-ret #:with-gensyms
+ #:mlet* #:make-array-allocator
+ #:nconsc
+ ;;Structure-specific
#:foreign-vector #:make-foreign-vector #:foreign-vector-p
#:fv-ref #:fv-pointer #:fv-size #:fv-type))
@@ -186,42 +181,45 @@
)
(:documentation "Fortran foreign function interface"))
-(defpackage "BLAS"
- #+:cmu (:use "COMMON-LISP" "ALIEN" "C-CALL" "FORTRAN-FFI-ACCESSORS")
- #+:sbcl (:use "COMMON-LISP" "SB-ALIEN" "SB-C" "FORTRAN-FFI-ACCESSORS")
- #+:allegro (:use "COMMON-LISP" "FOREIGN-FUNCTIONS" "FORTRAN-FFI-ACCESSORS")
- #+(or ccl ecl) (:use "COMMON-LISP" "FORTRAN-FFI-ACCESSORS")
+(defpackage :blas
+ (:use :commmon-lisp :fortran-ffi-accessors)
(:export
- "IDAMAX" "DASUM" "DDOT" "DNRM2"
- "DROT" "DSCAL" "DSWAP" "DCOPY" "DAXPY"
- "DCABS1" "DZASUM" "DZNRM2" "IZAMAX"
- "ZDSCAL" "ZSCAL" "ZSWAP" "ZCOPY" "ZAXPY" "ZDOTC" "ZDOTU"
- "DGEMV" "DSYMV" "DTRMV" "DTRSV" "DGER" "DSYR" "DSYR2"
- "ZGEMV" "ZHEMV" "ZTRMV" "ZTRSV" "ZGERC" "ZGERU" "ZHER2"
- "DGEMM" "DSYRK" "DSYR2K" "DTRMM" "DTRSM"
- "ZGEMM" "ZTRMM" "ZTRSM" "ZHERK" "ZHER2K" )
+ ;;BLAS Level 1
+ ;;------------
+ ;;Real-double
+ #:ddot #:dnrm2 #:dasum #:dscal #:daxpy #:drot
+ #:dswap #:dcopy #:idamax
+ ;;Complex-double
+ #:zdotc #:zdotu #:zdscal #:zscal #:zswap #:zcopy #:zaxpy
+ #:dcabs1 #:dzasum #:dznrm2 #:izamax
+ ;;BLAS Level 2
+ ;;------------
+ ;;Real-double
+ #:dgemv #:dsymv #:dtrmv #:dtrsv #:dger #:dsyr #:dsyr2
+ ;;Complex-double
+ #:zgemv #:zhemv #:ztrmv #:ztrsv #:zgerc #:zgeru #:zher2
+ ;;BLAS Level 3
+ ;;------------
+ ;;Real-double
+ #:dgemm #:dsyrk #:dsyr2k #:dtrmm #:dtrsm
+ ;;Complex-double
+ #:zgemm #:ztrmm #:ztrsm #:zherk #:zher2k)
(:documentation "BLAS routines"))
-(defpackage "LAPACK"
- #+:cmu (:use "COMMON-LISP" "ALIEN" "C-CALL" "FORTRAN-FFI-ACCESSORS")
- #+:sbcl (:use "COMMON-LISP" "SB-ALIEN" "SB-C" "FORTRAN-FFI-ACCESSORS")
- #+:allegro (:use "COMMON-LISP" "FOREIGN-FUNCTIONS" "FORTRAN-FFI-ACCESSORS")
- #+(or ccl ecl) (:use "COMMON-LISP" "FORTRAN-FFI-ACCESSORS")
+(defpackage :lapack
+ (:use :commmon-lisp :fortran-ffi-accessors)
(:export
- "DGESV" "DGEEV" "DGETRF" "DGETRS" "DGESVD"
- "ZGESV" "ZGEEV" "ZGETRF" "ZGETRS" "ZGESVD"
- "DGEQRF" "ZGEQRF" "DGEQP3" "ZGEQP3"
- "DORGQR" "ZUNGQR"
- "DPOTRS" "ZPOTRS" "DPOTRF" "ZPOTRF"
- "DGELSY")
+ #:dgesv #:dgeev #:dgetrf #:dgetrs #:dgesvd
+ #:zgesv #:zgeev #:zgetrf #:zgetrs #:zgesvd
+ #:dgeqrf #:zgeqrf #:dgeqp3 #:zgeqp3
+ #:dorgqr #:zungqr
+ #:dpotrs #:zpotrs #:dpotrf #:zpotrf
+ #:dgelsy)
(:documentation "LAPACK routines"))
-(defpackage "DFFTPACK"
- #+:cmu (:use "COMMON-LISP" "ALIEN" "C-CALL" "FORTRAN-FFI-ACCESSORS")
- #+:sbcl (:use "COMMON-LISP" "SB-ALIEN" "SB-C" "FORTRAN-FFI-ACCESSORS")
- #+:allegro (:use "COMMON-LISP" "FOREIGN-FUNCTIONS" "FORTRAN-FFI-ACCESSORS")
- #+(or ccl ecl) (:use "COMMON-LISP" "FORTRAN-FFI-ACCESSORS")
- (:export "ZFFTI" "ZFFTF" "ZFFTB")
+(defpackage :dfftpack
+ (:use :commmon-lisp :fortran-ffi-accessors)
+ (:export #:zffti #:zfftf #:zfftb #:zffti #:zfftf #:zfftb)
(:documentation "FFT routines"))
;; Stolen from f2cl.
@@ -303,6 +301,25 @@
(:use :common-lisp :fortran-ffi-accessors :blas :lapack :dfftpack :quadpack :matlisp-lib :utilities)
(:shadow #:real)
(:export #:*print-matrix*
+ ;;
+ #:integer4-type #:integer4-array #:allocate-integer4-store
+ #:index-type #:index-array #:allocate-index-store #:make-index-store
+ ;;Standard-tensor
+ #:standard-tensor
+ #:rank #:dimensions #:number-of-elements
+ #:head #:strides #:store-size #:store
+ ;;Sub-tensor
+ #:sub-tensor
+ #:parent-tensor
+ ;;Store indexers
+ #:store-indexing
+ #:store-indexing-internal #:store-indexing-vec #:store-indexing-lst
+ ;;Store accessors
+ #:tensor-store-ref
+ #:tensor-ref
+ ;;Type checking
+ #:tensor-type-p #:vector-p #:matrix-p #:square-p
+
;;Level 1 BLAS
#:axpy! #:axpy
#:copy! #:copy
@@ -318,7 +335,7 @@
#:standard-matrix
#:nrows #:ncols #:number-of-elements
#:head #:row-stride #:col-stride
- #:store #:store-size
+ #:store #:store-size
;;Generic functions on standard-matrix
#:fill-matrix
#:row-or-col-vector-p #:row-vector-p #:col-vector-p
diff --git a/src/conditions.lisp b/src/conditions.lisp
index 66cbcf7..9fdb937 100644
--- a/src/conditions.lisp
+++ b/src/conditions.lisp
@@ -25,6 +25,12 @@
(:report (lambda (c stream)
(format stream "Requested index ~A, but store is only of size ~A." (index c) (store-size c)))))
+(define-condition tensor-not-matrix (matlisp-error)
+ ((tensor-rank :reader rank :initarg :rank))
+ (:documentation "Given tensor is not a matrix.")
+ (:report (lambda (c stream)
+ (format stream "Given tensor with rank ~A, is not a matrix." (rank c)))))
+
(define-condition insufficient-store (matlisp-error)
((store-size :reader store-size :initarg :store-size)
(max-idx :reader max-idx :initarg :max-idx))
diff --git a/src/standard-matrix.lisp b/src/standard-matrix.lisp
index 4e0deab..ce2afb3 100644
--- a/src/standard-matrix.lisp
+++ b/src/standard-matrix.lisp
@@ -1,142 +1,51 @@
-;; Definitions of STANDARD-MATRIX
(in-package :matlisp)
;;
-(declaim (inline allocate-integer4-store))
-
-(eval-when (load eval compile)
- (deftype integer4-matrix-element-type ()
- '(signed-byte 32))
- )
-
-(defun allocate-integer4-store (size &optional (initial-element 0))
- "(ALLOCATE-INTEGER-STORE SIZE [INITIAL-ELEMENT]). Allocates
-integer storage. Default INITIAL-ELEMENT = 0."
- (make-array size
- :element-type 'integer4-matrix-element-type
- :initial-element initial-element))
-
-;;
-(declaim (inline store-indexing))
-(defun store-indexing (row col head row-stride col-stride)
- (declare (type (and fixnum (integer 0)) row col head row-stride col-stride))
- (the fixnum (+ head (the fixnum (* row row-stride)) (the fixnum (* col col-stride)))))
-
-(defun blas-copyable-p (matrix)
- (declare (optimize (safety 0) (speed 3))
- (type (or real-matrix complex-matrix) matrix))
- (mlet* ((nr (nrows matrix) :type fixnum)
- (nc (ncols matrix) :type fixnum)
- (rs (row-stride matrix) :type fixnum)
- (cs (col-stride matrix) :type fixnum)
- (ne (number-of-elements matrix) :type fixnum))
- (cond
- ((or (= nc 1) (= cs (* nr rs))) (values t rs ne))
- ((or (= nr 1) (= rs (* nc cs))) (values t cs ne))
- (t (values nil -1 -1)))))
-
-(defun blas-matrix-compatible-p (matrix &optional (op :n))
- (declare (optimize (safety 0) (speed 3))
- (type (or real-matrix complex-matrix) matrix))
- (mlet* (((rs cs) (slot-values matrix '(row-stride col-stride))
- :type (fixnum fixnum)))
- (cond
- ((= cs 1) (values :row-major rs (fortran-nop op)))
- ((= rs 1) (values :col-major cs (fortran-op op)))
- ;;Lets not confound lisp's type declaration.
- (t (values nil -1 "?")))))
-
-(declaim (inline fortran-op))
-(defun fortran-op (op)
- (ecase op (:n "N") (:t "T")))
-
-(declaim (inline fortran-nop))
-(defun fortran-nop (op)
- (ecase op (:t "N") (:n "T")))
-
-(defun fortran-snop (sop)
- (cond
- ((string= sop "N") "T")
- ((string= sop "T") "N")
- (t (error "Unrecognised fortran-op."))))
-
-;;
-(defclass standard-matrix ()
- ((number-of-rows
- :initarg :nrows
- :initform 0
- :accessor nrows
- :type fixnum
- :documentation "Number of rows in the matrix")
- (number-of-cols
- :initarg :ncols
- :initform 0
- :accessor ncols
- :type fixnum
- :documentation "Number of columns in the matrix")
- (number-of-elements
- :initform 0
- :accessor number-of-elements
- :type fixnum
- :documentation "Total number of elements in the matrix (nrows * ncols)")
- ;;
- (head
- :initarg :head
- :initform 0
- :accessor head
- :type fixnum
- :documentation "Head for the store's accessor.")
- (row-stride
- :initarg :row-stride
- :accessor row-stride
- :type fixnum
- :documentation "Row stride for the store's accessor.")
- (col-stride
- :initarg :col-stride
- :accessor col-stride
- :type fixnum
- :documentation "Column stride for the store's accessor.")
- (store-size
- :accessor store-size
- :type fixnum
- :documentation "Total number of elements needed to store the matrix. (Usually
-the same as nels, but not necessarily so!")
- (store
- :initarg :store
- :accessor store
- :documentation "The actual storage for the matrix. It is typically a one dimensional
-array but not necessarily so. The float and complex matrices do use
-1-D arrays. The complex matrix actually stores the real and imaginary
-parts in successive elements of the matrix because Fortran stores them
-that way."))
+(defclass standard-matrix (standard-tensor)
+ ((rank
+ :accessor rank
+ :type index-type
+ :initform 2
+ :documentation "For a matrix, rank = 2."))
(:documentation "Basic matrix class."))
+(defun nrows (matrix)
+ (declare (type standard-matrix matrix))
+ (let ((dims (dimensions matrix)))
+ (declare (type (index-array 2) dims))
+ (aref dims 0)))
+
+(defun ncols (matrix)
+ (declare (type standard-matrix matrix))
+ (let ((dims (dimensions matrix)))
+ (declare (type (index-array 2) dims))
+ (aref dims 1)))
+
+(defun row-stride (matrix)
+ (declare (type standard-matrix matrix))
+ (let ((stds (strides matrix)))
+ (declare (type (index-array 2) stds))
+ (aref stds 0)))
+
+(defun col-stride (matrix)
+ (declare (type standard-matrix matrix))
+ (let ((stds (strides matrix)))
+ (declare (type (index-array 2) stds))
+ (aref stds 1)))
+
+(defun size (matrix)
+ (declare (type standard-matrix matrix))
+ (let ((dims (dimensions matrix)))
+ (declare (type (index-array 2) dims))
+ (list (aref dims 0) (aref dims 1))))
;;
+
(defmethod initialize-instance :after ((matrix standard-matrix) &rest initargs)
(declare (ignore initargs))
(mlet*
- (((nr nc hd ss) (slot-values matrix '(number-of-rows number-of-cols head store-size))
- :type (fixnum fixnum fixnum fixnum)))
- ;;Row-ordered by default.
- (unless (and (slot-boundp matrix 'row-stride) (slot-boundp matrix 'col-stride))
- (setf (row-stride matrix) nc)
- (setf (col-stride matrix) 1))
- (let* ((rs (row-stride matrix))
- (cs (col-stride matrix))
- (l-idx (store-indexing (- nr 1) (- nc 1) hd rs cs)))
- (declare (type fixnum rs cs))
- ;;Error checking is good if we use foreign-pointers as store types.
- (cond
- ((<= nr 0) (error "Number of rows must be > 0. Initialized with ~A." nr))
- ((<= nc 0) (error "Number of columns must be > 0. Initialized with ~A." nc))
- ;;
- ((< hd 0) (error "Head of the store must be >= 0. Initialized with ~A." hd))
- ((< rs 0) (error "Row-stride of the store must be >= 0. Initialized with ~A." rs))
- ((< cs 0) (error "Column-stride of the store must be >= 0. Initialized with ~A." cs))
- ((<= ss l-idx) (error "Store is not large enough to hold the matrix.
-Initialized with ~A, but the largest possible index is ~A." ss l-idx))))
- ;;
- (setf (number-of-elements matrix) (* nr nc))))
+ ((rank (rank matrix) :type index-type))
+ (unless (= rank 2)
+ (error 'tensor-not-matrix :rank rank :tensor matrix))))
;;
(defmacro matrix-ref (matrix row &optional col)
@@ -145,131 +54,41 @@ Initialized with ~A, but the largest possible index is ~A." ss l-idx))))
`(matrix-ref-1d ,matrix ,row)))
;;
-(defgeneric matrix-ref-1d (matrix store-idx)
- (:documentation "
- Syntax
- ======
- (matrix-REF-1d store store-idx)
-
- Purpose
- =======
- Return the element store-idx of the matrix store."))
-
-#+nil(defmethod matrix-ref-1d :before ((matrix standard-matrix) (idx fixnum))
- (unless (< -1 (- idx (head matrix)) (number-of-elements matrix))
- (error "Requested index ~A is out of bounds.
-Matrix only has ~A elements." idx (number-of-elements matrix))))
-
-;;
-(defgeneric (setf matrix-ref-1d) (value matrix idx))
-
-#+nil(defmethod (setf matrix-ref-1d) :before ((value t) (matrix standard-matrix) (idx fixnum))
- (unless (< -1 idx (number-of-elements matrix))
- (error "Requested index ~A is out of bounds.
-Matrix only has ~A elements." idx (number-of-elements matrix))))
-
-;;
-(defgeneric matrix-ref-2d (matrix rows cols)
- (:documentation "
- Syntax
- ======
- (MATRIX-REF-2d store i j)
-
- Purpose
- =======
- Return the element
- (+
- (* (row-stride store) i)
- (* (col-stride store) j))
- of the store "))
-
-(defmethod matrix-ref-2d :before ((matrix standard-matrix) (rows fixnum) (cols fixnum))
- (unless (and (< -1 rows (nrows matrix))
- (< -1 cols (ncols matrix)))
- (error "Requested index (~A ~A) is out of bounds." rows cols)))
-
-(defmethod matrix-ref-2d ((matrix standard-matrix) (rows fixnum) (cols fixnum))
- (matrix-ref-1d matrix (store-indexing rows cols (head matrix) (row-stride matrix) (col-stride matrix))))
-
-;;
-(defgeneric (setf matrix-ref-2d) (value matrix rows cols))
-
-(defmethod (setf matrix-ref-2d) ((value t) (matrix standard-matrix) (rows fixnum) (cols fixnum))
- (setf (matrix-ref-1d matrix (store-indexing rows cols (head matrix) (row-stride matrix) (col-stride matrix))) value))
-
-;;
-(defgeneric row-vector-p (matrix)
- (:documentation "
+(defun row-vector-p (matrix)
+ "
Syntax
======
(ROW-VECTOR-P x)
Purpose
======...
[truncated message content] |
