Mercurial > octave
changeset 1:78fd87e624cb
[project @ 1993-08-08 01:13:40 by jwe]
Initial revision
line wrap: on
line diff
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/idx-vector.cc Sun Aug 08 01:13:40 1993 +0000 @@ -0,0 +1,249 @@ +// Very simple integer vectors for indexing -*- C++ -*- +/* + +Copyright (C) 1992, 1993 John W. Eaton + +This file is part of Octave. + +Octave is free software; you can redistribute it and/or modify it +under the terms of the GNU General Public License as published by the +Free Software Foundation; either version 2, or (at your option) any +later version. + +Octave is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +for more details. + +You should have received a copy of the GNU General Public License +along with Octave; see the file COPYING. If not, write to the Free +Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. + +*/ + +#ifdef __GNUG__ +#pragma implementation +#endif + +#include "idx-vector.h" +#include "error.h" +#include "user-prefs.h" +#include "utils.h" + +idx_vector::idx_vector (const idx_vector& a) +{ + len = a.len; + if (len > 0) + { + data = new int [len]; + for (int i = 0; i < len; i++) + data[i] = a.data[i]; + + num_zeros = a.num_zeros; + num_ones = a.num_ones; + one_zero = a.one_zero; + + max_val = a.max_val; + min_val = a.min_val; + } + else + data = 0; +} + +static inline int +tree_to_mat_idx (double x) +{ + if (x > 0) + return ((int) (x + 0.5) - 1); + else + return ((int) (x - 0.5) - 1); +} + +idx_vector::idx_vector (Matrix& m, int do_ftn_idx, char *rc, int z_len = 0) +{ + int nr = m.rows (); + int nc = m.columns (); + + if (nr == 0 || nc == 0) + { + len = 0; + data = 0; + num_zeros = 0; + num_ones = 0; + one_zero = 0; + return; + } + else if (nr > 1 && nc > 1 && do_ftn_idx) + { + double *cop_out = m.fortran_vec (); + len = nr * nc; + data = new int [len]; + for (int i = 0; i < len; i++) + data[i] = tree_to_mat_idx (*cop_out++); + } + else if (nr == 1 && nc > 0) + { + len = nc; + data = new int [len]; + for (int i = 0; i < len; i++) + data[i] = tree_to_mat_idx (m.elem (0, i)); + } + else if (nc == 1 && nr > 0) + { + len = nr; + data = new int [len]; + for (int i = 0; i < len; i++) + data[i] = tree_to_mat_idx (m.elem (i, 0)); + } + else + { + message ((char *) NULL, "invalid matrix index"); + jump_to_top_level (); + } + + init_state (rc, z_len); +} + +idx_vector::idx_vector (const Range& r) +{ + len = r.nelem (); + + assert (len != 0); + + double b = r.base (); + double step = r.inc (); + + data = new int [len]; + + for (int i = 0; i < len; i++) + { + double val = b + i * step; + data[i] = tree_to_mat_idx (val); + } + + init_state (); +} + +idx_vector& +idx_vector::operator = (const idx_vector& a) +{ + if (this != &a) + { + delete [] data; + len = a.len; + data = new int [len]; + for (int i = 0; i < len; i++) + data[i] = a.data[i]; + + num_zeros = a.num_zeros; + num_ones = a.num_ones; + one_zero = a.one_zero; + + max_val = a.max_val; + min_val = a.min_val; + } + return *this; +} + +void +idx_vector::init_state (char *rc, int z_len = 0) +{ + one_zero = 1; + num_zeros = 0; + num_ones = 0; + + min_val = max_val = data[0]; + + int i = 0; + do + { + if (data[i] == -1) + num_zeros++; + else if (data[i] == 0) + num_ones++; + + if (one_zero && data[i] != -1 && data[i] != 0) + one_zero = 0; + + if (data[i] > max_val) + max_val = data[i]; + + if (data[i] < min_val) + min_val = data[i]; + } + while (++i < len); + + if (one_zero && z_len == len) + { + if (num_zeros == len) + { + delete [] data; + len = 0; + data = 0; + num_zeros = 0; + num_ones = 0; + one_zero = 0; + } + else if (num_ones != len || user_pref.prefer_zero_one_indexing) + convert_one_zero_to_idx (); + } + else if (min_val < 0) + { + error ("%s index %d out of range", rc, min_val+1); + jump_to_top_level (); + } +} + +void +idx_vector::convert_one_zero_to_idx (void) +{ + if (num_ones == 0) + { + len = 0; + max_val = 0; + min_val = 0; + delete [] data; + } + else + { + assert (num_ones + num_zeros == len); + + int *new_data = new int [num_ones]; + int count = 0; + for (int i = 0; i < len; i++) + if (data[i] == 0) + new_data[count++] = i; + + delete [] data; + len = num_ones; + data = new_data; + + min_val = max_val = data[0]; + + i = 0; + do + { + if (data[i] > max_val) + max_val = data[i]; + + if (data[i] < min_val) + min_val = data[i]; + } + while (++i < len); + } +} + +ostream& +operator << (ostream& os, const idx_vector& a) +{ + for (int i = 0; i < a.len; i++) + os << a.data[i] << "\n"; + return os; +} + +/* +;;; Local Variables: *** +;;; mode: C++ *** +;;; page-delimiter: "^/\\*" *** +;;; End: *** +*/
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/idx-vector.h Sun Aug 08 01:13:40 1993 +0000 @@ -0,0 +1,137 @@ +// Very simple integer vectors for indexing -*- C++ -*- +/* + +Copyright (C) 1992, 1993 John W. Eaton + +This file is part of Octave. + +Octave is free software; you can redistribute it and/or modify it +under the terms of the GNU General Public License as published by the +Free Software Foundation; either version 2, or (at your option) any +later version. + +Octave is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +for more details. + +You should have received a copy of the GNU General Public License +along with Octave; see the file COPYING. If not, write to the Free +Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. + +*/ + +#if !defined (_idx_vector_h) +#define _idx_vector_h 1 + +#ifdef __GNUG__ +#pragma interface +#endif + +#include <stdlib.h> +#include <assert.h> +#include <iostream.h> +#include "Matrix.h" +#include "Range.h" + +#define FAIL assert(0) /* XXX FIXME XXX */ + +class idx_vector +{ +public: + idx_vector (void); + idx_vector (const idx_vector& a); + + idx_vector (Matrix& m, int do_ftn_idx, char *rc = (char *) NULL, + int z_len = 0); + + idx_vector (const Range& r); + + ~idx_vector (void); + + idx_vector& operator = (const idx_vector& a); + + int capacity (void) const; + int length (void) const; + + int elem (int n) const; + int checkelem (int n) const; + int operator () (int n) const; + +// other stuff + + int max (void) const; + int min (void) const; + + int one_zero_only (void) const; + int zeros_count (void) const; + int ones_count (void) const; + +// i/o + + friend ostream& operator << (ostream& os, const idx_vector& a); + +private: + + int len; + int one_zero; + int num_zeros; + int num_ones; + int max_val; + int min_val; + int *data; + + void init_state (char *rc = (char *) NULL, int z_len = 0); + void convert_one_zero_to_idx (void); +}; + +inline idx_vector::idx_vector (void) + { + len = 0; + data = 0; + num_zeros = 0; + num_ones = 0; + one_zero = 0; + } + +inline idx_vector::~idx_vector (void) + { + delete [] data; + data = 0; + num_zeros = 0; + num_ones = 0; + len = 0; + one_zero = 0; + } + +inline int idx_vector::capacity (void) const { return len; } +inline int idx_vector::length (void) const { return len; } + +inline int idx_vector::elem (int n) const { return data[n]; } + +inline int +idx_vector::checkelem (int n) const +{ + if (n < 0 || n >= len) + FAIL; + + return elem (n); +} + +inline int idx_vector::operator () (int n) const { return checkelem (n); } + +inline int idx_vector::max (void) const { return max_val; } +inline int idx_vector::min (void) const { return min_val; } + +inline int idx_vector::one_zero_only (void) const { return one_zero; } +inline int idx_vector::zeros_count (void) const { return num_zeros; } +inline int idx_vector::ones_count (void) const { return num_ones; } + +#endif + +/* +;;; Local Variables: *** +;;; mode: C++ *** +;;; page-delimiter: "^/\\*" *** +;;; End: *** +*/
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/statdefs.h Sun Aug 08 01:13:40 1993 +0000 @@ -0,0 +1,73 @@ +// statdefs.h -*- C++ -*- +/* + +Copyright (C) 1992, 1993 John W. Eaton + +This file is part of Octave. + +Octave is free software; you can redistribute it and/or modify it +under the terms of the GNU General Public License as published by the +Free Software Foundation; either version 2, or (at your option) any +later version. + +Octave is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +for more details. + +You should have received a copy of the GNU General Public License +along with Octave; see the file COPYING. If not, write to the Free +Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. + +*/ + +#if !defined (_statdefs_h) +#define _statdefs_h 1 + +#include <sys/types.h> +#include <sys/stat.h> + +#ifndef S_ISREG /* Doesn't have POSIX.1 stat stuff. */ +#define mode_t unsigned short +#endif +#if !defined(S_ISBLK) && defined(S_IFBLK) +#define S_ISBLK(m) (((m) & S_IFMT) == S_IFBLK) +#endif +#if !defined(S_ISCHR) && defined(S_IFCHR) +#define S_ISCHR(m) (((m) & S_IFMT) == S_IFCHR) +#endif +#if !defined(S_ISDIR) && defined(S_IFDIR) +#define S_ISDIR(m) (((m) & S_IFMT) == S_IFDIR) +#endif +#if !defined(S_ISREG) && defined(S_IFREG) +#define S_ISREG(m) (((m) & S_IFMT) == S_IFREG) +#endif +#if !defined(S_ISFIFO) && defined(S_IFIFO) +#define S_ISFIFO(m) (((m) & S_IFMT) == S_IFIFO) +#endif +#if !defined(S_ISLNK) && defined(S_IFLNK) +#define S_ISLNK(m) (((m) & S_IFMT) == S_IFLNK) +#endif +#if !defined(S_ISSOCK) && defined(S_IFSOCK) +#define S_ISSOCK(m) (((m) & S_IFMT) == S_IFSOCK) +#endif +#if !defined(S_ISMPB) && defined(S_IFMPB) /* V7 */ +#define S_ISMPB(m) (((m) & S_IFMT) == S_IFMPB) +#define S_ISMPC(m) (((m) & S_IFMT) == S_IFMPC) +#endif +#if !defined(S_ISNWK) && defined(S_IFNWK) /* HP/UX */ +#define S_ISNWK(m) (((m) & S_IFMT) == S_IFNWK) +#endif + +#ifndef S_ISLNK +#define lstat stat +#endif + +#endif + +/* +;;; Local Variables: *** +;;; mode: C++ *** +;;; page-delimiter: "^/\\*" *** +;;; End: *** +*/
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/SLStack.h Sun Aug 08 01:13:40 1993 +0000 @@ -0,0 +1,135 @@ +// This may look like C code, but it is really -*- C++ -*- +/* +Copyright (C) 1988 Free Software Foundation + written by Doug Lea (dl@rocky.oswego.edu) + +This file is part of the GNU C++ Library. This library is free +software; you can redistribute it and/or modify it under the terms of +the GNU Library General Public License as published by the Free +Software Foundation; either version 2 of the License, or (at your +option) any later version. This library is distributed in the hope +that it will be useful, but WITHOUT ANY WARRANTY; without even the +implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR +PURPOSE. See the GNU Library General Public License for more details. +You should have received a copy of the GNU Library General Public +License along with this library; if not, write to the Free Software +Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. +*/ + + +#ifndef _SLStack_h +#ifdef __GNUG__ +//#pragma interface +#endif +#define _SLStack_h 1 + +#include "SLList.h" +#include "Stack.h" + +template <class T> +class SLStack : public Stack<T> +{ + private: + SLList<T> p; + + public: + SLStack (void); + SLStack (const SLStack<T>& s); + ~SLStack (void); + + void operator = (const SLStack<T>&); + + void push (const T& item); + T pop (void); + T& top (void); + void del_top (void); + + int empty (void); + int full (void); + int length (void); + + void clear (void); + + int OK (void); +}; + +template <class T> +inline SLStack<T>::SLStack (void) : p () { } + +template <class T> +inline SLStack<T>::SLStack (const SLStack<T>& a) : p (a.p) { } + +template <class T> +inline SLStack<T>::~SLStack (void) { } + +template <class T> +inline void +SLStack<T>::push (const T& item) +{ + p.prepend (item); +} + +template <class T> +inline T +SLStack<T>::pop (void) +{ + return p.remove_front (); +} + +template <class T> +inline T& +SLStack<T>::top (void) +{ + return p.front (); +} + +template <class T> +inline void +SLStack<T>::del_top (void) +{ + p.del_front (); +} + +template <class T> +inline void +SLStack<T>::operator = (const SLStack<T>& s) +{ + p = s.p; +} + +template <class T> +inline int +SLStack<T>::empty (void) +{ + return p.empty (); +} + +template <class T> +inline int +SLStack<T>::full (void) +{ + return 0; +} + +template <class T> +inline int +SLStack<T>::length (void) +{ + return p.length (); +} + +template <class T> +inline int +SLStack<T>::OK (void) +{ + return p.OK (); +} + +template <class T> +inline void +SLStack<T>::clear (void) +{ + p.clear (); +} + +#endif
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/Stack.h Sun Aug 08 01:13:40 1993 +0000 @@ -0,0 +1,50 @@ +// This may look like C code, but it is really -*- C++ -*- +/* +Copyright (C) 1988 Free Software Foundation + written by Doug Lea (dl@rocky.oswego.edu) + +This file is part of the GNU C++ Library. This library is free +software; you can redistribute it and/or modify it under the terms of +the GNU Library General Public License as published by the Free +Software Foundation; either version 2 of the License, or (at your +option) any later version. This library is distributed in the hope +that it will be useful, but WITHOUT ANY WARRANTY; without even the +implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR +PURPOSE. See the GNU Library General Public License for more details. +You should have received a copy of the GNU Library General Public +License along with this library; if not, write to the Free Software +Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. +*/ + + +#ifndef _Stack_h +#ifdef __GNUG__ +//#pragma interface +#endif +#define _Stack_h 1 + +template <class T> +class Stack +{ + public: + Stack (void) { } + virtual ~Stack (void) { } + + virtual void push (const T& item) = 0; + + virtual T pop (void) = 0; + virtual T& top (void) = 0; + + virtual void del_top (void) = 0; + + virtual int empty (void) = 0; + virtual int full (void) = 0; + virtual int length (void) = 0; + + virtual void clear (void) = 0; + + void error (const char *msg); + virtual int OK (void) = 0; +}; + +#endif
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/arith-ops.cc Sun Aug 08 01:13:40 1993 +0000 @@ -0,0 +1,2368 @@ +// Helper functions for arithmetic operations. -*- C++ -*- +// Used by the tree class. +/* + +Copyright (C) 1992, 1993 John W. Eaton + +This file is part of Octave. + +Octave is free software; you can redistribute it and/or modify it +under the terms of the GNU General Public License as published by the +Free Software Foundation; either version 2, or (at your option) any +later version. + +Octave is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +for more details. + +You should have received a copy of the GNU General Public License +along with Octave; see the file COPYING. If not, write to the Free +Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. + +*/ + +#ifdef __GNUG__ +#pragma implementation +#endif + +#include <ctype.h> +#include <setjmp.h> +#include <math.h> + +#include "error.h" +#include "gripes.h" +#include "utils.h" +#include "mappers.h" +#include "user-prefs.h" +#include "tree-const.h" +#include "arith-ops.h" +#include "unwind-prot.h" +#include "xpow.h" +#include "xdiv.h" + +#if defined (HAVE_ISINF) || (defined (HAVE_FINITE) && defined (HAVE_ISNAN)) +#define DIVIDE_BY_ZERO_ERROR \ + do \ + { \ + if (user_pref.warn_divide_by_zero) \ + warning ("division by zero"); \ + } \ + while (0) +#else +#define DIVIDE_BY_ZERO_ERROR \ + do \ + { \ + error ("division by zero attempted"); \ + return tree_constant (); \ + } \ + while (0) +#endif + +// But first, some stupid functions that don\'t deserve to be in the +// Matrix class... + +enum +Matrix_bool_op +{ + Matrix_LT, + Matrix_LE, + Matrix_EQ, + Matrix_GE, + Matrix_GT, + Matrix_NE, + Matrix_AND, + Matrix_OR, +}; + +/* + * Stupid binary comparison operations like the ones Matlab provides. + * One for each type combination, in the order given here: + * + * op2 \ op1: s m cs cm + * +-- +---+---+----+----+ + * scalar | | * | 3 | * | 9 | + * +---+---+----+----+ + * matrix | 1 | 4 | 7 | 10 | + * +---+---+----+----+ + * complex_scalar | * | 5 | * | 11 | + * +---+---+----+----+ + * complex_matrix | 2 | 6 | 8 | 12 | + * +---+---+----+----+ + */ + +/* 1 */ +static Matrix +mx_stupid_bool_op (Matrix_bool_op op, double s, Matrix& a) +{ + int ar = a.rows (); + int ac = a.columns (); + Matrix t (ar, ac); + for (int j = 0; j < ac; j++) + for (int i = 0; i < ar; i++) + { + switch (op) + { + case Matrix_LT: + t.elem (i,j) = s < a.elem (i,j); + break; + case Matrix_LE: + t.elem (i,j) = s <= a.elem (i,j); + break; + case Matrix_EQ: + t.elem (i,j) = s == a.elem (i,j); + break; + case Matrix_GE: + t.elem (i,j) = s >= a.elem (i,j); + break; + case Matrix_GT: + t.elem (i,j) = s > a.elem (i,j); + break; + case Matrix_NE: + t.elem (i,j) = s != a.elem (i,j); + break; + case Matrix_AND: + t.elem (i,j) = s && a.elem (i,j); + break; + case Matrix_OR: + t.elem (i,j) = s || a.elem (i,j); + break; + default: + panic_impossible (); + break; + } + } + return t; +} + +/* 2 */ +static Matrix +mx_stupid_bool_op (Matrix_bool_op op, double s, ComplexMatrix& a) +{ + int ar = a.rows (); + int ac = a.columns (); + Matrix t (ar, ac); + for (int j = 0; j < ac; j++) + for (int i = 0; i < ar; i++) + { + switch (op) + { + case Matrix_LT: + t.elem (i,j) = s < real (a.elem (i,j)); + break; + case Matrix_LE: + t.elem (i,j) = s <= real (a.elem (i,j)); + break; + case Matrix_EQ: + t.elem (i,j) = s == a.elem (i,j); + break; + case Matrix_GE: + t.elem (i,j) = s >= real (a.elem (i,j)); + break; + case Matrix_GT: + t.elem (i,j) = s > real (a.elem (i,j)); + break; + case Matrix_NE: + t.elem (i,j) = s != a.elem (i,j); + break; + case Matrix_AND: + t.elem (i,j) = s && (a.elem (i,j) != 0.0); + break; + case Matrix_OR: + t.elem (i,j) = s || (a.elem (i,j) != 0.0); + break; + default: + panic_impossible (); + break; + } + } + return t; +} + +/* 3 */ +static Matrix +mx_stupid_bool_op (Matrix_bool_op op, Matrix& a, double s) +{ + int ar = a.rows (); + int ac = a.columns (); + Matrix t (ar, ac); + for (int j = 0; j < ac; j++) + for (int i = 0; i < ar; i++) + { + switch (op) + { + case Matrix_LT: + t.elem (i,j) = a.elem (i,j) < s; + break; + case Matrix_LE: + t.elem (i,j) = a.elem (i,j) <= s; + break; + case Matrix_EQ: + t.elem (i,j) = a.elem (i,j) == s; + break; + case Matrix_GE: + t.elem (i,j) = a.elem (i,j) >= s; + break; + case Matrix_GT: + t.elem (i,j) = a.elem (i,j) > s; + break; + case Matrix_NE: + t.elem (i,j) = a.elem (i,j) != s; + break; + case Matrix_AND: + t.elem (i,j) = a.elem (i,j) && s; + break; + case Matrix_OR: + t.elem (i,j) = a.elem (i,j) || s; + break; + default: + panic_impossible (); + break; + } + } + return t; +} + +/* 4 */ +static Matrix +mx_stupid_bool_op (Matrix_bool_op op, Matrix& a, Complex& s) +{ + int ar = a.rows (); + int ac = a.columns (); + Matrix t (ar, ac); + for (int j = 0; j < ac; j++) + for (int i = 0; i < ar; i++) + { + switch (op) + { + case Matrix_LT: + t.elem (i,j) = a.elem (i,j) < real (s); + break; + case Matrix_LE: + t.elem (i,j) = a.elem (i,j) <= real (s); + break; + case Matrix_EQ: + t.elem (i,j) = a.elem (i,j) == s; + break; + case Matrix_GE: + t.elem (i,j) = a.elem (i,j) >= real (s); + break; + case Matrix_GT: + t.elem (i,j) = a.elem (i,j) > real (s); + break; + case Matrix_NE: + t.elem (i,j) = a.elem (i,j) != s; + break; + case Matrix_AND: + t.elem (i,j) = a.elem (i,j) && (s != 0.0); + break; + case Matrix_OR: + t.elem (i,j) = a.elem (i,j) || (s != 0.0); + break; + default: + panic_impossible (); + break; + } + } + return t; +} + +/* 5 */ +static Matrix +mx_stupid_bool_op (Matrix_bool_op op, Matrix& a, Matrix& b) +{ + int ar = a.rows (); + int ac = a.columns (); + + if (ar != b.rows () || ac != b.columns ()) + { + gripe_nonconformant (); + jump_to_top_level (); + } + + Matrix c (ar, ac); + + for (int j = 0; j < ac; j++) + for (int i = 0; i < ar; i++) + { + switch (op) + { + case Matrix_LT: + c.elem (i, j) = a.elem (i, j) < b.elem (i, j); + break; + case Matrix_LE: + c.elem (i, j) = a.elem (i, j) <= b.elem (i, j); + break; + case Matrix_EQ: + c.elem (i, j) = a.elem (i, j) == b.elem (i, j); + break; + case Matrix_GE: + c.elem (i, j) = a.elem (i, j) >= b.elem (i, j); + break; + case Matrix_GT: + c.elem (i, j) = a.elem (i, j) > b.elem (i, j); + break; + case Matrix_NE: + c.elem (i, j) = a.elem (i, j) != b.elem (i, j); + break; + case Matrix_AND: + c.elem (i, j) = a.elem (i, j) && b.elem (i, j); + break; + case Matrix_OR: + c.elem (i, j) = a.elem (i, j) || b.elem (i, j); + break; + default: + panic_impossible (); + break; + } + } + return c; +} + +/* 6 */ +static Matrix +mx_stupid_bool_op (Matrix_bool_op op, Matrix& a, ComplexMatrix& b) +{ + int ar = a.rows (); + int ac = a.columns (); + + if (ar != b.rows () || ac != b.columns ()) + { + gripe_nonconformant (); + jump_to_top_level (); + } + + Matrix c (ar, ac); + + for (int j = 0; j < ac; j++) + for (int i = 0; i < ar; i++) + { + switch (op) + { + case Matrix_LT: + c.elem (i, j) = a.elem (i, j) < real (b.elem (i, j)); + break; + case Matrix_LE: + c.elem (i, j) = a.elem (i, j) <= real (b.elem (i, j)); + break; + case Matrix_EQ: + c.elem (i, j) = a.elem (i, j) == b.elem (i, j); + break; + case Matrix_GE: + c.elem (i, j) = a.elem (i, j) >= real (b.elem (i, j)); + break; + case Matrix_GT: + c.elem (i, j) = a.elem (i, j) > real (b.elem (i, j)); + break; + case Matrix_NE: + c.elem (i, j) = a.elem (i, j) != b.elem (i, j); + break; + case Matrix_AND: + c.elem (i, j) = a.elem (i, j) && (b.elem (i, j) != 0.0); + break; + case Matrix_OR: + c.elem (i, j) = a.elem (i, j) || (b.elem (i, j) != 0.0); + break; + default: + panic_impossible (); + break; + } + } + return c; +} + +/* 7 */ +static Matrix +mx_stupid_bool_op (Matrix_bool_op op, Complex& s, Matrix& a) +{ + int ar = a.rows (); + int ac = a.columns (); + Matrix t (ar, ac); + for (int j = 0; j < ac; j++) + for (int i = 0; i < ar; i++) + { + switch (op) + { + case Matrix_LT: + t.elem (i,j) = real (s) < a.elem (i,j); + break; + case Matrix_LE: + t.elem (i,j) = real (s) <= a.elem (i,j); + break; + case Matrix_EQ: + t.elem (i,j) = s == a.elem (i,j); + break; + case Matrix_GE: + t.elem (i,j) = real (s) >= a.elem (i,j); + break; + case Matrix_GT: + t.elem (i,j) = real (s) > a.elem (i,j); + break; + case Matrix_NE: + t.elem (i,j) = s != a.elem (i,j); + break; + case Matrix_AND: + t.elem (i,j) = (s != 0.0) && a.elem (i,j); + break; + case Matrix_OR: + t.elem (i,j) = (s != 0.0) || a.elem (i,j); + break; + default: + panic_impossible (); + break; + } + } + return t; +} + +/* 8 */ +static Matrix +mx_stupid_bool_op (Matrix_bool_op op, Complex& s, ComplexMatrix& a) +{ + int ar = a.rows (); + int ac = a.columns (); + Matrix t (ar, ac); + for (int j = 0; j < ac; j++) + for (int i = 0; i < ar; i++) + { + switch (op) + { + case Matrix_LT: + t.elem (i,j) = real (s) < real (a.elem (i,j)); + break; + case Matrix_LE: + t.elem (i,j) = real (s) <= real (a.elem (i,j)); + break; + case Matrix_EQ: + t.elem (i,j) = s == a.elem (i,j); + break; + case Matrix_GE: + t.elem (i,j) = real (s) >= real (a.elem (i,j)); + break; + case Matrix_GT: + t.elem (i,j) = real (s) > real (a.elem (i,j)); + break; + case Matrix_NE: + t.elem (i,j) = s != a.elem (i,j); + break; + case Matrix_AND: + t.elem (i,j) = (s != 0.0) && (a.elem (i,j) != 0.0); + break; + case Matrix_OR: + t.elem (i,j) = (s != 0.0) || (a.elem (i,j) != 0.0); + break; + default: + panic_impossible (); + break; + } + } + return t; +} + +/* 9 */ +static Matrix +mx_stupid_bool_op (Matrix_bool_op op, ComplexMatrix& a, double s) +{ + int ar = a.rows (); + int ac = a.columns (); + Matrix t (ar, ac); + for (int j = 0; j < ac; j++) + for (int i = 0; i < ar; i++) + { + switch (op) + { + case Matrix_LT: + t.elem (i,j) = real (a.elem (i,j)) < s; + break; + case Matrix_LE: + t.elem (i,j) = real (a.elem (i,j)) <= s; + break; + case Matrix_EQ: + t.elem (i,j) = a.elem (i,j) == s; + break; + case Matrix_GE: + t.elem (i,j) = real (a.elem (i,j)) >= s; + break; + case Matrix_GT: + t.elem (i,j) = real (a.elem (i,j)) > s; + break; + case Matrix_NE: + t.elem (i,j) = a.elem (i,j) != s; + break; + case Matrix_AND: + t.elem (i,j) = (a.elem (i,j) != 0.0) && s; + break; + case Matrix_OR: + t.elem (i,j) = (a.elem (i,j) != 0.0) || s; + break; + default: + panic_impossible (); + break; + } + } + return t; +} + +/* 10 */ +static Matrix +mx_stupid_bool_op (Matrix_bool_op op, ComplexMatrix& a, Complex& s) +{ + int ar = a.rows (); + int ac = a.columns (); + Matrix t (ar, ac); + for (int j = 0; j < ac; j++) + for (int i = 0; i < ar; i++) + { + switch (op) + { + case Matrix_LT: + t.elem (i,j) = real (a.elem (i,j)) < real (s); + break; + case Matrix_LE: + t.elem (i,j) = real (a.elem (i,j)) <= real (s); + break; + case Matrix_EQ: + t.elem (i,j) = a.elem (i,j) == s; + break; + case Matrix_GE: + t.elem (i,j) = real (a.elem (i,j)) >= real (s); + break; + case Matrix_GT: + t.elem (i,j) = real (a.elem (i,j)) > real (s); + break; + case Matrix_NE: + t.elem (i,j) = a.elem (i,j) != s; + break; + case Matrix_AND: + t.elem (i,j) = (a.elem (i,j) != 0.0) && (s != 0.0); + break; + case Matrix_OR: + t.elem (i,j) = (a.elem (i,j) != 0.0) || (s != 0.0); + break; + default: + panic_impossible (); + break; + } + } + return t; +} + +/* 11 */ +static Matrix +mx_stupid_bool_op (Matrix_bool_op op, ComplexMatrix& a, Matrix& b) +{ + int ar = a.rows (); + int ac = a.columns (); + + if (ar != b.rows () || ac != b.columns ()) + { + gripe_nonconformant (); + jump_to_top_level (); + } + + Matrix c (ar, ac); + + for (int j = 0; j < ac; j++) + for (int i = 0; i < ar; i++) + { + switch (op) + { + case Matrix_LT: + c.elem (i, j) = real (a.elem (i, j)) < b.elem (i, j); + break; + case Matrix_LE: + c.elem (i, j) = real (a.elem (i, j)) <= b.elem (i, j); + break; + case Matrix_EQ: + c.elem (i, j) = a.elem (i, j) == b.elem (i, j); + break; + case Matrix_GE: + c.elem (i, j) = real (a.elem (i, j)) >= b.elem (i, j); + break; + case Matrix_GT: + c.elem (i, j) = real (a.elem (i, j)) > b.elem (i, j); + break; + case Matrix_NE: + c.elem (i, j) = a.elem (i, j) != b.elem (i, j); + break; + case Matrix_AND: + c.elem (i, j) = (a.elem (i, j) != 0.0) && b.elem (i, j); + break; + case Matrix_OR: + c.elem (i, j) = (a.elem (i, j) != 0.0) || b.elem (i, j); + break; + default: + panic_impossible (); + break; + } + } + return c; +} + +/* 12 */ +static Matrix +mx_stupid_bool_op (Matrix_bool_op op, ComplexMatrix& a, ComplexMatrix& b) +{ + int ar = a.rows (); + int ac = a.columns (); + + if (ar != b.rows () || ac != b.columns ()) + { + gripe_nonconformant (); + jump_to_top_level (); + } + + Matrix c (ar, ac); + + for (int j = 0; j < ac; j++) + for (int i = 0; i < ar; i++) + { + switch (op) + { + case Matrix_LT: + c.elem (i, j) = real (a.elem (i, j)) < real (b.elem (i, j)); + break; + case Matrix_LE: + c.elem (i, j) = real (a.elem (i, j)) <= real (b.elem (i, j)); + break; + case Matrix_EQ: + c.elem (i, j) = a.elem (i, j) == b.elem (i, j); + break; + case Matrix_GE: + c.elem (i, j) = real (a.elem (i, j)) >= real (b.elem (i, j)); + break; + case Matrix_GT: + c.elem (i, j) = real (a.elem (i, j)) > real (b.elem (i, j)); + break; + case Matrix_NE: + c.elem (i, j) = a.elem (i, j) != b.elem (i, j); + break; + case Matrix_AND: + c.elem (i, j) = (a.elem (i, j) != 0.0) && (b.elem (i, j) != 0.0); + break; + case Matrix_OR: + c.elem (i, j) = (a.elem (i, j) != 0.0) || (b.elem (i, j) != 0.0); + break; + default: + panic_impossible (); + break; + } + } + return c; +} + +/* + * Check row and column dimensions for binary matrix operations. + */ +static inline int +m_add_conform (Matrix& m1, Matrix& m2, int warn) +{ + int ok = (m1.rows () == m2.rows () && m1.columns () == m2.columns ()); + if (!ok && warn) + gripe_nonconformant (); + return ok; +} + +static inline int +m_add_conform (Matrix& m1, ComplexMatrix& m2, int warn) +{ + int ok = (m1.rows () == m2.rows () && m1.columns () == m2.columns ()); + if (!ok && warn) + gripe_nonconformant (); + return ok; +} + +static inline int +m_add_conform (ComplexMatrix& m1, Matrix& m2, int warn) +{ + int ok = (m1.rows () == m2.rows () && m1.columns () == m2.columns ()); + if (!ok && warn) + gripe_nonconformant (); + return ok; +} + +static inline int +m_add_conform (ComplexMatrix& m1, ComplexMatrix& m2, int warn) +{ + int ok = (m1.rows () == m2.rows () && m1.columns () == m2.columns ()); + if (!ok && warn) + gripe_nonconformant (); + return ok; +} + +static inline int +m_mul_conform (Matrix& m1, Matrix& m2, int warn) +{ + int ok = (m1.columns () == m2.rows ()); + if (!ok && warn) + gripe_nonconformant (); + return ok; +} + +static inline int +m_mul_conform (Matrix& m1, ComplexMatrix& m2, int warn) +{ + int ok = (m1.columns () == m2.rows ()); + if (!ok && warn) + gripe_nonconformant (); + return ok; +} + +static inline int +m_mul_conform (ComplexMatrix& m1, Matrix& m2, int warn) +{ + int ok = (m1.columns () == m2.rows ()); + if (!ok && warn) + gripe_nonconformant (); + return ok; +} + +static inline int +m_mul_conform (ComplexMatrix& m1, ComplexMatrix& m2, int warn) +{ + int ok = (m1.columns () == m2.rows ()); + if (!ok && warn) + gripe_nonconformant (); + return ok; +} + +/* + * Unary operations. One for each numeric data type: + * + * scalar + * complex_scalar + * matrix + * complex_matrix + * + */ + +tree_constant +do_unary_op (double d, tree::expression_type t) +{ + double result = 0.0; + switch (t) + { + case tree::not: + result = (! d); + break; + case tree::uminus: + result = -d; + break; + case tree::hermitian: + case tree::transpose: + result = d; + break; + default: + panic_impossible (); + break; + } + + return tree_constant (result); +} + +tree_constant +do_unary_op (Matrix& a, tree::expression_type t) +{ + Matrix result; + switch (t) + { + case tree::not: + result = (! a); + break; + case tree::uminus: + result = -a; + break; + case tree::hermitian: + case tree::transpose: + result = a.transpose (); + break; + default: + panic_impossible (); + break; + } + + return tree_constant (result); +} + +tree_constant +do_unary_op (Complex& c, tree::expression_type t) +{ + Complex result = 0.0; + switch (t) + { + case tree::not: + result = (c == 0.0); + break; + case tree::uminus: + result = -c; + break; + case tree::hermitian: + result = conj (c); + break; + case tree::transpose: + result = c; + break; + default: + panic_impossible (); + break; + } + + return tree_constant (result); +} + +tree_constant +do_unary_op (ComplexMatrix& a, tree::expression_type t) +{ + ComplexMatrix result; + switch (t) + { + case tree::not: + result = (! a); + break; + case tree::uminus: + result = -a; + break; + case tree::hermitian: + result = a.hermitian (); + break; + case tree::transpose: + result = a.transpose (); + break; + default: + panic_impossible (); + break; + } + + return tree_constant (result); +} + +/* + * Binary operations. One for each type combination, in the order + * given here: + * + * op2 \ op1: s m cs cm + * +-- +---+---+----+----+ + * scalar | | 1 | 5 | 9 | 13 | + * +---+---+----+----+ + * matrix | 2 | 6 | 10 | 14 | + * +---+---+----+----+ + * complex_scalar | 3 | 7 | 11 | 15 | + * +---+---+----+----+ + * complex_matrix | 4 | 8 | 12 | 16 | + * +---+---+----+----+ + */ + +/* 1 */ +tree_constant +do_binary_op (double a, double b, tree::expression_type t) +{ + double result = 0.0; + switch (t) + { + case tree::add: + result = a + b; + break; + case tree::subtract: + result = a - b; + break; + case tree::multiply: + case tree::el_mul: + result = a * b; + break; + case tree::divide: + case tree::el_div: + if (b == 0.0) + DIVIDE_BY_ZERO_ERROR; + result = a / b; + break; + case tree::leftdiv: + case tree::el_leftdiv: + if (a == 0.0) + DIVIDE_BY_ZERO_ERROR; + result = b / a; + break; + case tree::power: + case tree::elem_pow: + return xpow (a, b); + break; + case tree::cmp_lt: + result = a < b; + break; + case tree::cmp_le: + result = a <= b; + break; + case tree::cmp_eq: + result = a == b; + break; + case tree::cmp_ge: + result = a >= b; + break; + case tree::cmp_gt: + result = a > b; + break; + case tree::cmp_ne: + result = a != b; + break; + case tree::and: + result = (a && b); + break; + case tree::or: + result = (a || b); + break; + default: + panic_impossible (); + break; + } + + return tree_constant (result); +} + +/* 2 */ +tree_constant +do_binary_op (double a, Matrix& b, tree::expression_type t) +{ + Matrix result; + switch (t) + { + case tree::add: + result = a + b; + break; + case tree::subtract: + result = a - b; + break; + case tree::el_leftdiv: + case tree::leftdiv: + if (a == 0.0) + DIVIDE_BY_ZERO_ERROR; + a = 1.0 / a; +// fall through... + case tree::multiply: + case tree::el_mul: + result = a * b; + break; + case tree::el_div: + return x_el_div (a, b); + break; + case tree::divide: + error ("nonconformant right division"); + return tree_constant (); + break; + case tree::power: + return xpow (a, b); + break; + case tree::elem_pow: + return elem_xpow (a, b); + break; + case tree::cmp_lt: + result = mx_stupid_bool_op (Matrix_LT, a, b); + break; + case tree::cmp_le: + result = mx_stupid_bool_op (Matrix_LE, a, b); + break; + case tree::cmp_eq: + result = mx_stupid_bool_op (Matrix_EQ, a, b); + break; + case tree::cmp_ge: + result = mx_stupid_bool_op (Matrix_GE, a, b); + break; + case tree::cmp_gt: + result = mx_stupid_bool_op (Matrix_GT, a, b); + break; + case tree::cmp_ne: + result = mx_stupid_bool_op (Matrix_NE, a, b); + break; + case tree::and: + result = mx_stupid_bool_op (Matrix_AND, a, b); + break; + case tree::or: + result = mx_stupid_bool_op (Matrix_OR, a, b); + break; + default: + panic_impossible (); + break; + } + + return tree_constant (result); +} + +/* 3 */ +tree_constant +do_binary_op (double a, Complex& b, tree::expression_type t) +{ + enum RT { RT_unknown, RT_real, RT_complex }; + RT result_type = RT_unknown; + + double result = 0.0; + Complex complex_result; + switch (t) + { + case tree::add: + result_type = RT_complex; + complex_result = a + b; + break; + case tree::subtract: + result_type = RT_complex; + complex_result = a - b; + break; + case tree::multiply: + case tree::el_mul: + result_type = RT_complex; + complex_result = a * b; + break; + case tree::divide: + case tree::el_div: + result_type = RT_complex; + if (b == 0.0) + DIVIDE_BY_ZERO_ERROR; + complex_result = a / b; + break; + case tree::leftdiv: + case tree::el_leftdiv: + result_type = RT_complex; + if (a == 0.0) + DIVIDE_BY_ZERO_ERROR; + complex_result = b / a; + break; + case tree::power: + case tree::elem_pow: + return xpow (a, b); + break; + case tree::cmp_lt: + result_type = RT_real; + result = a < real (b); + break; + case tree::cmp_le: + result_type = RT_real; + result = a <= real (b); + break; + case tree::cmp_eq: + result_type = RT_real; + result = a == b; + break; + case tree::cmp_ge: + result_type = RT_real; + result = a >= real (b); + break; + case tree::cmp_gt: + result_type = RT_real; + result = a > real (b); + break; + case tree::cmp_ne: + result_type = RT_real; + result = a != b; + break; + case tree::and: + result_type = RT_real; + result = (a && (b != 0.0)); + break; + case tree::or: + result_type = RT_real; + result = (a || (b != 0.0)); + break; + default: + panic_impossible (); + break; + } + + assert (result_type != RT_unknown); + if (result_type == RT_real) + return tree_constant (result); + else + return tree_constant (complex_result); +} + +/* 4 */ +tree_constant +do_binary_op (double a, ComplexMatrix& b, tree::expression_type t) +{ + enum RT { RT_unknown, RT_real, RT_complex }; + RT result_type = RT_unknown; + + Matrix result; + ComplexMatrix complex_result; + switch (t) + { + case tree::add: + result_type = RT_complex; + complex_result = a + b; + break; + case tree::subtract: + result_type = RT_complex; + complex_result = a - b; + break; + case tree::el_leftdiv: + case tree::leftdiv: + if (a == 0.0) + DIVIDE_BY_ZERO_ERROR; + a = 1.0 / a; +// fall through... + case tree::multiply: + case tree::el_mul: + result_type = RT_complex; + complex_result = a * b; + break; + case tree::el_div: + return x_el_div (a, b); + break; + case tree::divide: + error ("nonconformant right division"); + return tree_constant (); + break; + case tree::power: + return xpow (a, b); + break; + case tree::elem_pow: + return elem_xpow (a, b); + break; + case tree::cmp_lt: + result_type = RT_real; + result = mx_stupid_bool_op (Matrix_LT, a, b); + break; + case tree::cmp_le: + result_type = RT_real; + result = mx_stupid_bool_op (Matrix_LE, a, b); + break; + case tree::cmp_eq: + result_type = RT_real; + result = mx_stupid_bool_op (Matrix_EQ, a, b); + break; + case tree::cmp_ge: + result_type = RT_real; + result = mx_stupid_bool_op (Matrix_GE, a, b); + break; + case tree::cmp_gt: + result_type = RT_real; + result = mx_stupid_bool_op (Matrix_GT, a, b); + break; + case tree::cmp_ne: + result_type = RT_real; + result = mx_stupid_bool_op (Matrix_NE, a, b); + break; + case tree::and: + result_type = RT_real; + result = mx_stupid_bool_op (Matrix_AND, a, b); + break; + case tree::or: + result_type = RT_real; + result = mx_stupid_bool_op (Matrix_OR, a, b); + break; + default: + panic_impossible (); + break; + } + + assert (result_type != RT_unknown); + if (result_type == RT_real) + return tree_constant (result); + else + return tree_constant (complex_result); +} + +/* 5 */ +tree_constant +do_binary_op (Matrix& a, double b, tree::expression_type t) +{ + Matrix result; + switch (t) + { + case tree::add: + result = a + b; + break; + case tree::subtract: + result = a - b; + break; + case tree::multiply: + case tree::el_mul: + result = a * b; + break; + case tree::divide: + case tree::el_div: + result = a / b; + break; + case tree::el_leftdiv: + return x_el_div (b, a); + break; + case tree::leftdiv: + error ("nonconformant left division"); + return tree_constant (); + break; + case tree::power: + return xpow (a, b); + break; + case tree::elem_pow: + return elem_xpow (a, b); + break; + case tree::cmp_lt: + result = mx_stupid_bool_op (Matrix_LT, a, b); + break; + case tree::cmp_le: + result = mx_stupid_bool_op (Matrix_LE, a, b); + break; + case tree::cmp_eq: + result = mx_stupid_bool_op (Matrix_EQ, a, b); + break; + case tree::cmp_ge: + result = mx_stupid_bool_op (Matrix_GE, a, b); + break; + case tree::cmp_gt: + result = mx_stupid_bool_op (Matrix_GT, a, b); + break; + case tree::cmp_ne: + result = mx_stupid_bool_op (Matrix_NE, a, b); + break; + case tree::and: + result = mx_stupid_bool_op (Matrix_AND, a, b); + break; + case tree::or: + result = mx_stupid_bool_op (Matrix_OR, a, b); + break; + default: + panic_impossible (); + break; + } + + return tree_constant (result); +} + +/* 6 */ +tree_constant +do_binary_op (Matrix& a, Matrix& b, tree::expression_type t) +{ + Matrix result; + + int error_cond = 0; + + switch (t) + { + case tree::add: + if (m_add_conform (a, b, 1)) + result = a + b; + else + error_cond = 1; + break; + case tree::subtract: + if (m_add_conform (a, b, 1)) + result = a - b; + else + error_cond = 1; + break; + case tree::el_mul: + if (m_add_conform (a, b, 1)) + result = a.product (b); + else + error_cond = 1; + break; + case tree::multiply: + if (m_mul_conform (a, b, 1)) + result = a * b; + else + error_cond = 1; + break; + case tree::el_div: + if (m_add_conform (a, b, 1)) + result = a.quotient (b); + else + error_cond = 1; + break; + case tree::el_leftdiv: + if (m_add_conform (a, b, 1)) + result = b.quotient (a); + else + error_cond = 1; + break; + case tree::leftdiv: + return xleftdiv (a, b); + break; + case tree::divide: + return xdiv (a, b); + break; + case tree::power: + error ("can't do A ^ B for A and B both matrices"); + error_cond = 1; + break; + case tree::elem_pow: + if (m_add_conform (a, b, 1)) + return elem_xpow (a, b); + else + error_cond = 1; + break; + case tree::cmp_lt: + if (m_add_conform (a, b, 1)) + result = mx_stupid_bool_op (Matrix_LT, a, b); + else + error_cond = 1; + break; + case tree::cmp_le: + if (m_add_conform (a, b, 1)) + result = mx_stupid_bool_op (Matrix_LE, a, b); + else + error_cond = 1; + break; + case tree::cmp_eq: + if (m_add_conform (a, b, 1)) + result = mx_stupid_bool_op (Matrix_EQ, a, b); + else + error_cond = 1; + break; + case tree::cmp_ge: + if (m_add_conform (a, b, 1)) + result = mx_stupid_bool_op (Matrix_GE, a, b); + else + error_cond = 1; + break; + case tree::cmp_gt: + if (m_add_conform (a, b, 1)) + result = mx_stupid_bool_op (Matrix_GT, a, b); + else + error_cond = 1; + break; + case tree::cmp_ne: + if (m_add_conform (a, b, 1)) + result = mx_stupid_bool_op (Matrix_NE, a, b); + else + error_cond = 1; + break; + case tree::and: + if (m_add_conform (a, b, 1)) + result = mx_stupid_bool_op (Matrix_AND, a, b); + else + error_cond = 1; + break; + case tree::or: + if (m_add_conform (a, b, 1)) + result = mx_stupid_bool_op (Matrix_OR, a, b); + else + error_cond = 1; + break; + default: + panic_impossible (); + break; + } + + if (error_cond) + return tree_constant (); + else + return tree_constant (result); +} + +/* 7 */ +tree_constant +do_binary_op (Matrix& a, Complex& b, tree::expression_type t) +{ + enum RT { RT_unknown, RT_real, RT_complex }; + RT result_type = RT_unknown; + + Matrix result; + ComplexMatrix complex_result; + switch (t) + { + case tree::add: + result_type = RT_complex; + complex_result = a + b; + break; + case tree::subtract: + result_type = RT_complex; + complex_result = a - b; + break; + case tree::multiply: + case tree::el_mul: + result_type = RT_complex; + complex_result = a * b; + break; + case tree::divide: + case tree::el_div: + result_type = RT_complex; + complex_result = a / b; + break; + case tree::el_leftdiv: + return x_el_div (b, a); + break; + case tree::leftdiv: + error ("nonconformant left division"); + return tree_constant (); + break; + case tree::power: + return xpow (a, b); + break; + case tree::elem_pow: + return elem_xpow (a, b); + break; + case tree::cmp_lt: + result_type = RT_real; + result = mx_stupid_bool_op (Matrix_LT, a, b); + break; + case tree::cmp_le: + result_type = RT_real; + result = mx_stupid_bool_op (Matrix_LE, a, b); + break; + case tree::cmp_eq: + result_type = RT_real; + result = mx_stupid_bool_op (Matrix_EQ, a, b); + break; + case tree::cmp_ge: + result_type = RT_real; + result = mx_stupid_bool_op (Matrix_GE, a, b); + break; + case tree::cmp_gt: + result_type = RT_real; + result = mx_stupid_bool_op (Matrix_GT, a, b); + break; + case tree::cmp_ne: + result_type = RT_real; + result = mx_stupid_bool_op (Matrix_NE, a, b); + break; + case tree::and: + result_type = RT_real; + result = mx_stupid_bool_op (Matrix_AND, a, b); + break; + case tree::or: + result_type = RT_real; + result = mx_stupid_bool_op (Matrix_OR, a, b); + break; + default: + panic_impossible (); + break; + } + + assert (result_type != RT_unknown); + if (result_type == RT_real) + return tree_constant (result); + else + return tree_constant (complex_result); +} + +/* 8 */ +tree_constant +do_binary_op (Matrix& a, ComplexMatrix& b, tree::expression_type t) +{ + enum RT { RT_unknown, RT_real, RT_complex }; + RT result_type = RT_unknown; + + Matrix result; + ComplexMatrix complex_result; + switch (t) + { + case tree::add: + result_type = RT_complex; + if (m_add_conform (a, b, 1)) + complex_result = a + b; + else + return tree_constant (); + break; + case tree::subtract: + result_type = RT_complex; + if (m_add_conform (a, b, 1)) + complex_result = a - b; + else + return tree_constant (); + break; + case tree::el_mul: + result_type = RT_complex; + if (m_add_conform (a, b, 1)) + complex_result = a.product (b); + else + return tree_constant (); + break; + case tree::multiply: + result_type = RT_complex; + if (m_mul_conform (a, b, 1)) + complex_result = a * b; + else + return tree_constant (); + break; + case tree::el_div: + result_type = RT_complex; + if (m_add_conform (a, b, 1)) + complex_result = a.quotient (b); + else + return tree_constant (); + break; + case tree::el_leftdiv: + result_type = RT_complex; + if (m_add_conform (a, b, 1)) + complex_result = b.quotient (a); + else + return tree_constant (); + break; + case tree::leftdiv: + return xleftdiv (a, b); + break; + case tree::divide: + return xdiv (a, b); + break; + case tree::power: + error ("can't do A ^ B for A and B both matrices"); + return tree_constant (); + break; + case tree::elem_pow: + if (m_add_conform (a, b, 1)) + return elem_xpow (a, b); + else + return tree_constant (); + break; + case tree::cmp_lt: + result_type = RT_real; + if (m_add_conform (a, b, 1)) + result = mx_stupid_bool_op (Matrix_LT, a, b); + else + return tree_constant (); + break; + case tree::cmp_le: + result_type = RT_real; + if (m_add_conform (a, b, 1)) + result = mx_stupid_bool_op (Matrix_LE, a, b); + else + return tree_constant (); + break; + case tree::cmp_eq: + result_type = RT_real; + if (m_add_conform (a, b, 1)) + result = mx_stupid_bool_op (Matrix_EQ, a, b); + else + return tree_constant (); + break; + case tree::cmp_ge: + result_type = RT_real; + if (m_add_conform (a, b, 1)) + result = mx_stupid_bool_op (Matrix_GE, a, b); + else + return tree_constant (); + break; + case tree::cmp_gt: + result_type = RT_real; + if (m_add_conform (a, b, 1)) + result = mx_stupid_bool_op (Matrix_GT, a, b); + else + return tree_constant (); + break; + case tree::cmp_ne: + result_type = RT_real; + if (m_add_conform (a, b, 1)) + result = mx_stupid_bool_op (Matrix_NE, a, b); + else + return tree_constant (); + break; + case tree::and: + result_type = RT_real; + if (m_add_conform (a, b, 1)) + result = mx_stupid_bool_op (Matrix_AND, a, b); + else + return tree_constant (); + break; + case tree::or: + result_type = RT_real; + if (m_add_conform (a, b, 1)) + result = mx_stupid_bool_op (Matrix_OR, a, b); + else + return tree_constant (); + break; + default: + panic_impossible (); + break; + } + + assert (result_type != RT_unknown); + if (result_type == RT_real) + return tree_constant (result); + else + return tree_constant (complex_result); +} + +/* 9 */ +tree_constant +do_binary_op (Complex& a, double b, tree::expression_type t) +{ + enum RT { RT_unknown, RT_real, RT_complex }; + RT result_type = RT_unknown; + + double result = 0.0; + Complex complex_result; + switch (t) + { + case tree::add: + result_type = RT_complex; + complex_result = a + b; + break; + case tree::subtract: + result_type = RT_complex; + complex_result = a - b; + break; + case tree::multiply: + case tree::el_mul: + result_type = RT_complex; + complex_result = a * b; + break; + case tree::divide: + case tree::el_div: + result_type = RT_complex; + if (b == 0.0) + DIVIDE_BY_ZERO_ERROR; + complex_result = a / b; + break; + case tree::leftdiv: + case tree::el_leftdiv: + result_type = RT_complex; + if (a == 0.0) + DIVIDE_BY_ZERO_ERROR; + complex_result = b / a; + break; + case tree::power: + case tree::elem_pow: + return xpow (a, b); + break; + case tree::cmp_lt: + result_type = RT_real; + result = real (a) < b; + break; + case tree::cmp_le: + result_type = RT_real; + result = real (a) <= b; + break; + case tree::cmp_eq: + result_type = RT_real; + result = a == b; + break; + case tree::cmp_ge: + result_type = RT_real; + result = real (a) >= b; + break; + case tree::cmp_gt: + result_type = RT_real; + result = real (a) > b; + break; + case tree::cmp_ne: + result_type = RT_real; + result = a != b; + break; + case tree::and: + result_type = RT_real; + result = ((a != 0.0) && b); + break; + case tree::or: + result_type = RT_real; + result = ((a != 0.0) || b); + break; + default: + panic_impossible (); + break; + } + + assert (result_type != RT_unknown); + if (result_type == RT_real) + return tree_constant (result); + else + return tree_constant (complex_result); +} + +/* 10 */ +tree_constant +do_binary_op (Complex& a, Matrix& b, tree::expression_type t) +{ + enum RT { RT_unknown, RT_real, RT_complex }; + RT result_type = RT_unknown; + + Matrix result; + ComplexMatrix complex_result; + switch (t) + { + case tree::add: + result_type = RT_complex; + complex_result = a + b; + break; + case tree::subtract: + result_type = RT_complex; + complex_result = a - b; + break; + case tree::el_leftdiv: + case tree::leftdiv: + if (a == 0.0) + DIVIDE_BY_ZERO_ERROR; + a = 1.0 / a; +// fall through... + case tree::multiply: + case tree::el_mul: + result_type = RT_complex; + complex_result = a * b; + break; + case tree::el_div: + return x_el_div (a, b); + break; + case tree::divide: + error ("nonconformant right division"); + return tree_constant (); + break; + case tree::power: + return xpow (a, b); + break; + case tree::elem_pow: + return elem_xpow (a, b); + break; + case tree::cmp_lt: + result_type = RT_real; + result = mx_stupid_bool_op (Matrix_LT, a, b); + break; + case tree::cmp_le: + result_type = RT_real; + result = mx_stupid_bool_op (Matrix_LE, a, b); + break; + case tree::cmp_eq: + result_type = RT_real; + result = mx_stupid_bool_op (Matrix_EQ, a, b); + break; + case tree::cmp_ge: + result_type = RT_real; + result = mx_stupid_bool_op (Matrix_GE, a, b); + break; + case tree::cmp_gt: + result_type = RT_real; + result = mx_stupid_bool_op (Matrix_GT, a, b); + break; + case tree::cmp_ne: + result_type = RT_real; + result = mx_stupid_bool_op (Matrix_NE, a, b); + break; + case tree::and: + result_type = RT_real; + result = mx_stupid_bool_op (Matrix_AND, a, b); + break; + case tree::or: + result_type = RT_real; + result = mx_stupid_bool_op (Matrix_OR, a, b); + break; + default: + panic_impossible (); + break; + } + + assert (result_type != RT_unknown); + if (result_type == RT_real) + return tree_constant (result); + else + return tree_constant (complex_result); +} + +/* 11 */ +tree_constant +do_binary_op (Complex& a, Complex& b, tree::expression_type t) +{ + enum RT { RT_unknown, RT_real, RT_complex }; + RT result_type = RT_unknown; + + double result = 0.0; + Complex complex_result; + switch (t) + { + case tree::add: + result_type = RT_complex; + complex_result = a + b; + break; + case tree::subtract: + result_type = RT_complex; + complex_result = a - b; + break; + case tree::multiply: + case tree::el_mul: + result_type = RT_complex; + complex_result = a * b; + break; + case tree::divide: + case tree::el_div: + result_type = RT_complex; + if (b == 0.0) + DIVIDE_BY_ZERO_ERROR; + complex_result = a / b; + break; + case tree::leftdiv: + case tree::el_leftdiv: + result_type = RT_complex; + if (a == 0.0) + DIVIDE_BY_ZERO_ERROR; + complex_result = b / a; + break; + case tree::power: + case tree::elem_pow: + return xpow (a, b); + break; + case tree::cmp_lt: + result_type = RT_real; + result = real (a) < real (b); + break; + case tree::cmp_le: + result_type = RT_real; + result = real (a) <= real (b); + break; + case tree::cmp_eq: + result_type = RT_real; + result = a == b; + break; + case tree::cmp_ge: + result_type = RT_real; + result = real (a) >= real (b); + break; + case tree::cmp_gt: + result_type = RT_real; + result = real (a) > real (b); + break; + case tree::cmp_ne: + result_type = RT_real; + result = a != b; + break; + case tree::and: + result_type = RT_real; + result = ((a != 0.0) && (b != 0.0)); + break; + case tree::or: + result_type = RT_real; + result = ((a != 0.0) || (b != 0.0)); + break; + default: + panic_impossible (); + break; + } + + assert (result_type != RT_unknown); + if (result_type == RT_real) + return tree_constant (result); + else + return tree_constant (complex_result); +} + +/* 12 */ +tree_constant +do_binary_op (Complex& a, ComplexMatrix& b, tree::expression_type t) +{ + enum RT { RT_unknown, RT_real, RT_complex }; + RT result_type = RT_unknown; + + Matrix result; + ComplexMatrix complex_result; + switch (t) + { + case tree::add: + result_type = RT_complex; + complex_result = a + b; + break; + case tree::subtract: + result_type = RT_complex; + complex_result = a - b; + break; + case tree::el_leftdiv: + case tree::leftdiv: + if (a == 0.0) + DIVIDE_BY_ZERO_ERROR; + a = 1.0 / a; +// fall through... + case tree::multiply: + case tree::el_mul: + result_type = RT_complex; + complex_result = a * b; + break; + case tree::el_div: + return x_el_div (a, b); + break; + case tree::divide: + error ("nonconformant right division"); + return tree_constant (); + break; + case tree::power: + return xpow (a, b); + break; + case tree::elem_pow: + return elem_xpow (a, b); + break; + case tree::cmp_lt: + result_type = RT_real; + result = mx_stupid_bool_op (Matrix_LT, a, b); + break; + case tree::cmp_le: + result_type = RT_real; + result = mx_stupid_bool_op (Matrix_LE, a, b); + break; + case tree::cmp_eq: + result_type = RT_real; + result = mx_stupid_bool_op (Matrix_EQ, a, b); + break; + case tree::cmp_ge: + result_type = RT_real; + result = mx_stupid_bool_op (Matrix_GE, a, b); + break; + case tree::cmp_gt: + result_type = RT_real; + result = mx_stupid_bool_op (Matrix_GT, a, b); + break; + case tree::cmp_ne: + result_type = RT_real; + result = mx_stupid_bool_op (Matrix_NE, a, b); + break; + case tree::and: + result_type = RT_real; + result = mx_stupid_bool_op (Matrix_AND, a, b); + break; + case tree::or: + result_type = RT_real; + result = mx_stupid_bool_op (Matrix_OR, a, b); + break; + default: + panic_impossible (); + break; + } + + assert (result_type != RT_unknown); + if (result_type == RT_real) + return tree_constant (result); + else + return tree_constant (complex_result); +} + +/* 13 */ +tree_constant +do_binary_op (ComplexMatrix& a, double b, tree::expression_type t) +{ + enum RT { RT_unknown, RT_real, RT_complex }; + RT result_type = RT_unknown; + + Matrix result; + ComplexMatrix complex_result; + switch (t) + { + case tree::add: + result_type = RT_complex; + complex_result = a + b; + break; + case tree::subtract: + result_type = RT_complex; + complex_result = a - b; + break; + case tree::multiply: + case tree::el_mul: + result_type = RT_complex; + complex_result = a * b; + break; + case tree::divide: + case tree::el_div: + result_type = RT_complex; + complex_result = a / b; + break; + case tree::el_leftdiv: + return x_el_div (b, a); + break; + case tree::leftdiv: + error ("nonconformant left division"); + return tree_constant (); + break; + case tree::power: + return xpow (a, b); + break; + case tree::elem_pow: + return elem_xpow (a, b); + break; + case tree::cmp_lt: + result_type = RT_real; + result = mx_stupid_bool_op (Matrix_LT, a, b); + break; + case tree::cmp_le: + result_type = RT_real; + result = mx_stupid_bool_op (Matrix_LE, a, b); + break; + case tree::cmp_eq: + result_type = RT_real; + result = mx_stupid_bool_op (Matrix_EQ, a, b); + break; + case tree::cmp_ge: + result_type = RT_real; + result = mx_stupid_bool_op (Matrix_GE, a, b); + break; + case tree::cmp_gt: + result_type = RT_real; + result = mx_stupid_bool_op (Matrix_GT, a, b); + break; + case tree::cmp_ne: + result_type = RT_real; + result = mx_stupid_bool_op (Matrix_NE, a, b); + break; + case tree::and: + result_type = RT_real; + result = mx_stupid_bool_op (Matrix_AND, a, b); + break; + case tree::or: + result_type = RT_real; + result = mx_stupid_bool_op (Matrix_OR, a, b); + break; + default: + panic_impossible (); + break; + } + + assert (result_type != RT_unknown); + if (result_type == RT_real) + return tree_constant (result); + else + return tree_constant (complex_result); +} + +/* 14 */ +tree_constant +do_binary_op (ComplexMatrix& a, Matrix& b, tree::expression_type t) +{ + enum RT { RT_unknown, RT_real, RT_complex }; + RT result_type = RT_unknown; + + Matrix result; + ComplexMatrix complex_result; + switch (t) + { + case tree::add: + result_type = RT_complex; + if (m_add_conform (a, b, 1)) + complex_result = a + b; + else + return tree_constant (); + break; + case tree::subtract: + result_type = RT_complex; + if (m_add_conform (a, b, 1)) + complex_result = a - b; + else + return tree_constant (); + break; + case tree::el_mul: + result_type = RT_complex; + if (m_add_conform (a, b, 1)) + complex_result = a.product (b); + else + return tree_constant (); + break; + case tree::multiply: + result_type = RT_complex; + if (m_mul_conform (a, b, 1)) + complex_result = a * b; + else + return tree_constant (); + break; + case tree::el_div: + result_type = RT_complex; + if (m_add_conform (a, b, 1)) + complex_result = a.quotient (b); + else + return tree_constant (); + break; + case tree::el_leftdiv: + result_type = RT_complex; + if (m_add_conform (a, b, 1)) + complex_result = a.quotient (b); + else + return tree_constant (); + break; + case tree::leftdiv: + return xleftdiv (a, b); + break; + case tree::divide: + return xdiv (a, b); + break; + case tree::power: + error ("can't do A ^ B for A and B both matrices"); + return tree_constant (); + break; + case tree::elem_pow: + if (m_add_conform (a, b, 1)) + return elem_xpow (a, b); + else + return tree_constant (); + break; + case tree::cmp_lt: + result_type = RT_real; + if (m_add_conform (a, b, 1)) + result = mx_stupid_bool_op (Matrix_LT, a, b); + else + return tree_constant (); + break; + case tree::cmp_le: + result_type = RT_real; + if (m_add_conform (a, b, 1)) + result = mx_stupid_bool_op (Matrix_LE, a, b); + else + return tree_constant (); + break; + case tree::cmp_eq: + result_type = RT_real; + if (m_add_conform (a, b, 1)) + result = mx_stupid_bool_op (Matrix_EQ, a, b); + else + return tree_constant (); + break; + case tree::cmp_ge: + result_type = RT_real; + if (m_add_conform (a, b, 1)) + result = mx_stupid_bool_op (Matrix_GE, a, b); + else + return tree_constant (); + break; + case tree::cmp_gt: + result_type = RT_real; + if (m_add_conform (a, b, 1)) + result = mx_stupid_bool_op (Matrix_GT, a, b); + else + return tree_constant (); + break; + case tree::cmp_ne: + result_type = RT_real; + if (m_add_conform (a, b, 1)) + result = mx_stupid_bool_op (Matrix_NE, a, b); + else + return tree_constant (); + break; + case tree::and: + result_type = RT_real; + if (m_add_conform (a, b, 1)) + result = mx_stupid_bool_op (Matrix_AND, a, b); + else + return tree_constant (); + break; + case tree::or: + result_type = RT_real; + if (m_add_conform (a, b, 1)) + result = mx_stupid_bool_op (Matrix_OR, a, b); + else + return tree_constant (); + break; + default: + panic_impossible (); + break; + } + + assert (result_type != RT_unknown); + if (result_type == RT_real) + return tree_constant (result); + else + return tree_constant (complex_result); +} + +/* 15 */ +tree_constant +do_binary_op (ComplexMatrix& a, Complex& b, tree::expression_type t) +{ + enum RT { RT_unknown, RT_real, RT_complex }; + RT result_type = RT_unknown; + + Matrix result; + ComplexMatrix complex_result; + switch (t) + { + case tree::add: + result_type = RT_complex; + complex_result = a + b; + break; + case tree::subtract: + result_type = RT_complex; + complex_result = a - b; + break; + case tree::multiply: + case tree::el_mul: + result_type = RT_complex; + complex_result = a * b; + break; + case tree::divide: + case tree::el_div: + result_type = RT_complex; + complex_result = a / b; + break; + case tree::el_leftdiv: + return x_el_div (b, a); + break; + case tree::leftdiv: + error ("nonconformant left division"); + return tree_constant (); + break; + case tree::power: + return xpow (a, b); + break; + case tree::elem_pow: + return elem_xpow (a, b); + break; + case tree::cmp_lt: + result_type = RT_real; + result = mx_stupid_bool_op (Matrix_LT, a, b); + break; + case tree::cmp_le: + result_type = RT_real; + result = mx_stupid_bool_op (Matrix_LE, a, b); + break; + case tree::cmp_eq: + result_type = RT_real; + result = mx_stupid_bool_op (Matrix_EQ, a, b); + break; + case tree::cmp_ge: + result_type = RT_real; + result = mx_stupid_bool_op (Matrix_GE, a, b); + break; + case tree::cmp_gt: + result_type = RT_real; + result = mx_stupid_bool_op (Matrix_GT, a, b); + break; + case tree::cmp_ne: + result_type = RT_real; + result = mx_stupid_bool_op (Matrix_NE, a, b); + break; + case tree::and: + result_type = RT_real; + result = mx_stupid_bool_op (Matrix_AND, a, b); + break; + case tree::or: + result_type = RT_real; + result = mx_stupid_bool_op (Matrix_OR, a, b); + break; + default: + panic_impossible (); + break; + } + + assert (result_type != RT_unknown); + if (result_type == RT_real) + return tree_constant (result); + else + return tree_constant (complex_result); +} + +/* 16 */ +tree_constant +do_binary_op (ComplexMatrix& a, ComplexMatrix& b, tree::expression_type t) +{ + enum RT { RT_unknown, RT_real, RT_complex }; + RT result_type = RT_unknown; + + Matrix result; + ComplexMatrix complex_result; + switch (t) + { + case tree::add: + result_type = RT_complex; + if (m_add_conform (a, b, 1)) + complex_result = a + b; + else + return tree_constant (); + break; + case tree::subtract: + result_type = RT_complex; + if (m_add_conform (a, b, 1)) + complex_result = a - b; + else + return tree_constant (); + break; + case tree::el_mul: + result_type = RT_complex; + if (m_add_conform (a, b, 1)) + complex_result = a.product (b); + else + return tree_constant (); + break; + case tree::multiply: + result_type = RT_complex; + if (m_mul_conform (a, b, 1)) + complex_result = a * b; + else + return tree_constant (); + break; + case tree::el_div: + result_type = RT_complex; + if (m_add_conform (a, b, 1)) + complex_result = a.quotient (b); + else + return tree_constant (); + break; + case tree::el_leftdiv: + result_type = RT_complex; + if (m_add_conform (a, b, 1)) + complex_result = b.quotient (a); + else + return tree_constant (); + break; + case tree::leftdiv: + return xleftdiv (a, b); + break; + case tree::divide: + return xdiv (a, b); + break; + case tree::power: + error ("can't do A ^ B for A and B both matrices"); + return tree_constant (); + break; + case tree::elem_pow: + if (m_add_conform (a, b, 1)) + return elem_xpow (a, b); + else + return tree_constant (); + break; + case tree::cmp_lt: + result_type = RT_real; + if (m_add_conform (a, b, 1)) + result = mx_stupid_bool_op (Matrix_LT, a, b); + else + return tree_constant (); + break; + case tree::cmp_le: + result_type = RT_real; + if (m_add_conform (a, b, 1)) + result = mx_stupid_bool_op (Matrix_LE, a, b); + else + return tree_constant (); + break; + case tree::cmp_eq: + result_type = RT_real; + if (m_add_conform (a, b, 1)) + result = mx_stupid_bool_op (Matrix_EQ, a, b); + else + return tree_constant (); + break; + case tree::cmp_ge: + result_type = RT_real; + if (m_add_conform (a, b, 1)) + result = mx_stupid_bool_op (Matrix_GE, a, b); + else + return tree_constant (); + break; + case tree::cmp_gt: + result_type = RT_real; + if (m_add_conform (a, b, 1)) + result = mx_stupid_bool_op (Matrix_GT, a, b); + else + return tree_constant (); + break; + case tree::cmp_ne: + result_type = RT_real; + if (m_add_conform (a, b, 1)) + result = mx_stupid_bool_op (Matrix_NE, a, b); + else + return tree_constant (); + break; + case tree::and: + result_type = RT_real; + if (m_add_conform (a, b, 1)) + result = mx_stupid_bool_op (Matrix_AND, a, b); + else + return tree_constant (); + break; + case tree::or: + result_type = RT_real; + if (m_add_conform (a, b, 1)) + result = mx_stupid_bool_op (Matrix_OR, a, b); + else + return tree_constant (); + break; + default: + panic_impossible (); + break; + } + + assert (result_type != RT_unknown); + if (result_type == RT_real) + return tree_constant (result); + else + return tree_constant (complex_result); +} + +/* +;;; Local Variables: *** +;;; mode: C++ *** +;;; page-delimiter: "^/\\*" *** +;;; End: *** +*/
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/arith-ops.h Sun Aug 08 01:13:40 1993 +0000 @@ -0,0 +1,101 @@ +// Helper functions for arithmetic operations. -*- C++ -*- +// Used by the tree class. +/* + +Copyright (C) 1992, 1993 John W. Eaton + +This file is part of Octave. + +Octave is free software; you can redistribute it and/or modify it +under the terms of the GNU General Public License as published by the +Free Software Foundation; either version 2, or (at your option) any +later version. + +Octave is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +for more details. + +You should have received a copy of the GNU General Public License +along with Octave; see the file COPYING. If not, write to the Free +Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. + +*/ + +#if !defined (_arith_ops_h) +#define _arith_ops_h 1 + +#ifdef __GNUG__ +#pragma interface +#endif + +#include "tree-const.h" + +extern tree_constant +do_unary_op (double d, tree::expression_type t); + +extern tree_constant +do_unary_op (Matrix& a, tree::expression_type t); + +extern tree_constant +do_unary_op (Complex& c, tree::expression_type t); + +extern tree_constant +do_unary_op (ComplexMatrix& a, tree::expression_type t); + +extern tree_constant +do_binary_op (double a, double b, tree::expression_type t); + +extern tree_constant +do_binary_op (double a, Matrix& b, tree::expression_type t); + +extern tree_constant +do_binary_op (double a, Complex& b, tree::expression_type t); + +extern tree_constant +do_binary_op (double a, ComplexMatrix& b, tree::expression_type t); + +extern tree_constant +do_binary_op (Matrix& a, double b, tree::expression_type t); + +extern tree_constant +do_binary_op (Matrix& a, Matrix& b, tree::expression_type t); + +extern tree_constant +do_binary_op (Matrix& a, Complex& b, tree::expression_type t); + +extern tree_constant +do_binary_op (Matrix& a, ComplexMatrix& b, tree::expression_type t); + +extern tree_constant +do_binary_op (Complex& a, double b, tree::expression_type t); + +extern tree_constant +do_binary_op (Complex& a, Matrix& b, tree::expression_type t); + +extern tree_constant +do_binary_op (Complex& a, Complex& b, tree::expression_type t); + +extern tree_constant +do_binary_op (Complex& a, ComplexMatrix& b, tree::expression_type t); + +extern tree_constant +do_binary_op (ComplexMatrix& a, double b, tree::expression_type t); + +extern tree_constant +do_binary_op (ComplexMatrix& a, Matrix& b, tree::expression_type t); + +extern tree_constant +do_binary_op (ComplexMatrix& a, Complex& b, tree::expression_type t); + +extern tree_constant +do_binary_op (ComplexMatrix& a, ComplexMatrix& b, tree::expression_type t); + +#endif + +/* +;;; Local Variables: *** +;;; mode: C++ *** +;;; page-delimiter: "^/\\*" *** +;;; End: *** +*/
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/builtins.cc Sun Aug 08 01:13:40 1993 +0000 @@ -0,0 +1,1025 @@ +// builtins.cc -*- C++ -*- +/* + +Copyright (C) 1992, 1993 John W. Eaton + +This file is part of Octave. + +Octave is free software; you can redistribute it and/or modify it +under the terms of the GNU General Public License as published by the +Free Software Foundation; either version 2, or (at your option) any +later version. + +Octave is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +for more details. + +You should have received a copy of the GNU General Public License +along with Octave; see the file COPYING. If not, write to the Free +Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. + +*/ + +#ifdef __GNUG__ +#pragma implementation +#endif + +#include <iostream.h> +#include <math.h> +#include <float.h> + +#include "tree-const.h" +#include "symtab.h" +#include "t-builtins.h" +#include "g-builtins.h" +#include "builtins.h" +#include "octave.h" +#include "utils.h" +#include "tree.h" +#include "mappers.h" +#include "user-prefs.h" +#include "variables.h" + +// NOTE: nargin == 1 means that the function takes no arguments (just +// like C, the first argument is (or should be, anyway) the function +// name). Also, -1 is shorthand for infinity. + +// The following initializations may eventually need to be reworked +// like the builtin functions in bash were around version 1.12... + +static builtin_mapper_functions mapper_functions[] = +{ + { "abs", 2, 1, 0, fabs, abs, NULL, + "compute abs(X) for each element of X\n", }, + + { "acos", 2, 1, 0, acos, NULL, acos, + "compute acos(X) for each element of X\n", }, + + { "acosh", 2, 1, 0, acosh, NULL, acosh, + "compute acosh(X) for each element of X\n", }, + + { "angle", 2, 1, 0, arg, arg, NULL, + "compute arg(X) for each element of X\n", }, + + { "arg", 2, 1, 0, arg, arg, NULL, + "compute arg(X) for each element of X\n", }, + + { "asin", 2, 1, 0, asin, NULL, asin, + "compute asin(X) for each element of X\n", }, + + { "asinh", 2, 1, 0, asinh, NULL, asinh, + "compute asinh(X) for each element of X\n", }, + + { "atan", 2, 1, 0, atan, NULL, atan, + "compute atan(X) for each element of X\n", }, + + { "atanh", 2, 1, 0, atanh, NULL, atanh, + "compute atanh(X) for each element of X\n", }, + + { "ceil", 2, 1, 0, ceil, NULL, ceil, + "ceil(X): round elements of X toward +Inf\n", }, + + { "conj", 2, 1, 0, conj, NULL, conj, + "compute complex conjugate for each element of X\n", }, + + { "cos", 2, 1, 0, cos, NULL, cos, + "compute cos(X) for each element of X\n", }, + + { "cosh", 2, 1, 0, cosh, NULL, cosh, + "compute cosh(X) for each element of X\n", }, + + { "exp", 2, 1, 0, exp, NULL, exp, + "compute exp(X) for each element of X\n", }, + + { "finite", 2, 1, 0, xfinite, xfinite, NULL, + "finite(X): return 1 for finite elements of X\n", }, + + { "fix", 2, 1, 0, fix, NULL, fix, + "fix(X): round elements of X toward zero\n", }, + + { "floor", 2, 1, 0, floor, NULL, floor, + "floor(X): round elements of X toward -Inf\n", }, + + { "isinf", 2, 1, 0, xisinf, xisinf, NULL, + "isinf(X): return 1 for elements of X infinite\n", }, + + { "imag", 2, 1, 0, imag, imag, NULL, + "return imaginary part for each elements of X\n", }, + +#ifdef HAVE_ISNAN + { "isnan", 2, 1, 0, xisnan, xisnan, NULL, + "isnan(X): return 1 where elements of X are NaNs\n", }, +#endif + + { "log", 2, 1, 1, log, NULL, log, + "compute log(X) for each element of X\n", }, + + { "log10", 2, 1, 1, log10, NULL, log10, + "compute log10(X) for each element of X\n", }, + + { "real", 2, 1, 0, real, real, NULL, + "return real part for each element of X\n", }, + + { "round", 2, 1, 0, round, NULL, round, + "round(X): round elements of X to nearest integer\n", }, + + { "sign", 2, 1, 0, signum, NULL, signum, + "sign(X): apply signum function to elements of X\n", }, + + { "sin", 2, 1, 0, sin, NULL, sin, + "compute sin(X) for each element of X\n", }, + + { "sinh", 2, 1, 0, sinh, NULL, sinh, + "compute sinh(X) for each element of X\n", }, + + { "sqrt", 2, 1, 1, sqrt, NULL, sqrt, + "compute sqrt(X) for each element of X\n", }, + + { "tan", 2, 1, 0, tan, NULL, tan, + "compute tan(X) for each element of X\n", }, + + { "tanh", 2, 1, 0, tanh, NULL, tanh, + "compute tanh(X) for each element of X\n", }, + + { NULL, -1, -1, -1, NULL, NULL, NULL, NULL, }, +}; + +static builtin_text_functions text_functions[] = +{ + { "casesen", 2, builtin_casesen, + "print warning if user tries to change case sensitivity\n", }, + + { "cd", 2, builtin_cd, + "change current working directory\n", }, + + { "clear", -1, builtin_clear, + "clear symbol(s) from symbol table\n", }, + + { "dir", -1, builtin_ls, + "print a directory listing\n", }, + + { "document", -1, builtin_document, + "define help string for symbol\n", }, + + { "edit_history", -1, builtin_edit_history, + "usage: edit_history [first] [last]\n", }, + + { "format", -1, builtin_format, + "set output formatting style\n", }, + + { "help", -1, builtin_help, + "print cryptic yet witty messages\n", }, + + { "history", -1, builtin_history, + "print/save/load command history\n", }, + + { "load", -1, builtin_load, + "load variables from a file\n", }, + + { "ls", -1, builtin_ls, + "print a directory listing\n", }, + + { "save", -1, builtin_save, + "save variables to a file\n", }, + + { "set", -1, builtin_set, + "set plotting options\n", }, + + { "show", -1, builtin_show, + "show plotting options\n", }, + + { "who", -1, builtin_who, + "list symbols\n", }, + + { NULL, -1, NULL, NULL, }, +}; + +static builtin_general_functions general_functions[] = +{ + { "all", 2, 1, builtin_all, + "all(X): are all elements of X nonzero?\n", }, + + { "any", 2, 1, builtin_any, + "any(X): are any elements of X nonzero?\n", }, + + { "clc", 1, 0, builtin_clc, + "clear screen\n", }, + + { "clock", 1, 0, builtin_clock, + "return current date and time in vector\n", }, + + { "closeplot", 1, 0, builtin_closeplot, + "close the stream to plotter\n", }, + + { "colloc", 7, 4, builtin_colloc, + "[r, A, B, q] = colloc (n [, 'left'] [, 'right']): collocation weights\n", }, + + { "cumprod", 2, 1, builtin_cumprod, + "cumprod (X): cumulative products\n", }, + + { "cumsum", 2, 1, builtin_cumsum, + "cumsum (X): cumulative sums\n", }, + + { "dassl", 5, 1, builtin_dassl, + "solve DAEs using Petzold's DASSL. Usage:\n\ +\n\ + dassl ('function_name', x_0, xdot_0, t_out)\n\ + dassl ('function_name', x_0, xdot_0, t_out, t_crit)\n\ +\n\ +The first argument is the name of the function to call to\n\ +compute the vector of residuals. It must have the form\n\ +\n\ + res = f (x, xdot, t)\n\ +\n\ +where x, xdot, and res are vectors, and t is a scalar.\n\n", }, + + { "date", 1, 0, builtin_date, + "return current date in a string\n", }, + + { "det", 2, 1, builtin_det, + "det(X): determinant of a square matrix\n", }, + + { "diag", 3, 1, builtin_diag, + "diag(X [,k]): form/extract diagonals\n", }, + + { "disp", 3, 1, builtin_disp, + "disp(X): display value\n", }, + + { "eig", 2, 1, builtin_eig, + "eig (x): compute eigenvalues and eigenvectors of x\n", }, + + { "error", 2, 1, builtin_error, + "print message and jump to top level\n", }, + + { "eval", 2, 1, builtin_eval, + "evaluate text as octave source\n", }, + + { "exist", 2, 1, builtin_exist, + "check if variable or file exists\n", }, + + { "exit", 1, 0, builtin_quit, + "exit Octave gracefully\n", }, + + { "expm", 2, 1, builtin_expm, + "Matrix exponential, e^A\n", }, + + { "eye", 3, 1, builtin_eye, + "create an identity matrix\n", }, + + { "fclose", 2, 1, builtin_fclose, + "fclose('filename' or filenum): close a file\n", }, + + { "feval", -1, 1, builtin_feval, + "evaluate argument as function\n", }, + + { "fflush", 2, 1, builtin_fflush, + "fflush('filename' or filenum): flush buffered data to output file\n", }, + + { "fft", 2, 1, builtin_fft, + "fft(X): fast fourier transform of a vector\n", }, + + { "fgets",3, 2, builtin_fgets, + "[string, length] = fgets('filename' or filenum, length): read a string from a file\n", }, + + { "find", -1, 1, builtin_find, + "find (x): return vector of indices of nonzero elements\n", }, + + { "flops", 2, 1, builtin_flops, + "count floating point operations\n", }, + + { "fopen", 3, 1, builtin_fopen, + "filenum = fopen('filename','mode'): open a file\n", }, + + { "fprintf", -1, 1, builtin_fprintf, + "fprintf ('file', 'fmt', ...)\n", }, + + { "freport", 1, 1, builtin_freport, + "freport: list open files and their status\n", }, + + { "frewind", 2, 1, builtin_frewind, + "frewind('filename' or filenum): set file position at beginning of file\n", }, + + { "fscanf", 3, -1, builtin_fscanf, + "[a,b,c...] = fscanf ('file', 'fmt')\n", }, + + { "fseek", 4, 1, builtin_fseek, + "fseek('filename' or filenum): set file position for reading or writing\n", }, + + { "fsolve", 5, 1, builtin_fsolve, + "Solve nonlinear equations using Minpack. Usage:\n\ +\n\ + [x, info] = fsolve ('f', x0)\n\ +\n\ +Where the first argument is the name of the function to call to\n\ +compute the vector of function values. It must have the form\n\ +\n\ + y = f (x) +\n\ +where y and x are vectors.\n\n", }, + + { "fsqp", 11, 3, builtin_fsqp, + "solve NLPs\n", }, + + { "ftell", 2, 1, builtin_ftell, + "position = ftell ('filename' or filenum): returns the current file position\n", }, + + { "getenv", 2, 1, builtin_getenv, + "get environment variable values\n", }, + + { "hess", 2, 2, builtin_hess, + "Hessenburg decomposition\n",}, + + { "home", 1, 0, builtin_clc, + "clear screen\n", }, + + { "input", 3, 1, builtin_input, + "input('prompt' [,'s']): prompt user for [string] input\n", }, + + { "ifft", 2, 1, builtin_ifft, + "ifft(X): inverse fast fourier transform of a vector\n", }, + + { "inv", 2, 1, builtin_inv, + "inv(X): inverse of a square matrix\n", }, + + { "inverse", 2, 1, builtin_inv, + "inverse(X): inverse of a square matrix\n", }, + + { "isstr", 2, 1, builtin_isstr, + "isstr(X): return 1 if X is a string\n", }, + + { "keyboard", 2, 1, builtin_keyboard, + "maybe help in debugging M-files\n", }, + + { "logm", 2, 1, builtin_logm, + "Matrix logarithm, log (A)\n", }, + + { "lpsolve", 11, 3, builtin_lpsolve, + "Solve linear programs using lp_solve.\n", }, + + { "lsode", 6, 1, builtin_lsode, + "solve ODEs using Hindmarsh's LSODE. Usage:\n\ +\n\ + lsode ('function_name', x0, t_out\n\ + lsode ('function_name', x0, t_out, t_crit)\n\ +\n\ +The first argument is the name of the function to call to\n\ +compute the vector of right hand sides. It must have the form\n\ +\n\ + xdot = f (x, t)\n\ +\n\ +where xdot and x are vectors and t is a scalar.\n\n", }, + + { "lu", 2, 3, builtin_lu, + "[L, U, P] = lu (A) -- LU factorization\n", }, + + { "max", 3, 2, builtin_max, + "maximum value(s) of a vector (matrix)\n", }, + + { "min", 3, 2, builtin_min, + "minimum value(s) of a vector (matrix)\n", }, + + { "npsol", 11, 3, builtin_npsol, + "Solve nonlinear programs using Gill and Murray's NPSOL. Usage:\n\ +\n\ + [x, obj, info, lambda] = npsol (x, 'phi' [, lb, ub] [, lb, A, ub] [, lb, 'g', ub])\n\n\ +Groups of arguments surrounded in `[]' are optional, but\n\ +must appear in the same relative order shown above.\n\ +\n\ +The second argument is a string containing the name of the objective\n\ +function to call. The objective function must be of the form\n\ +\n\ + y = phi (x)\n\ +\n\ +where x is a vector and y is a scalar.\n\n", }, + + { "ones", 3, 1, builtin_ones, + "create a matrix of all ones\n", }, + + { "pause", 1, 0, builtin_pause, + "suspend program execution\n", }, + + { "purge_tmp_files", 5, 1, builtin_purge_tmp_files, + "delete temporary data files used for plotting\n", }, + + { "printf", -1, 1, builtin_printf, + "printf ('fmt', ...)\n", }, + + { "prod", 2, 1, builtin_prod, + "prod (X): products\n", }, + + { "pwd", 1, 0, builtin_pwd, + "print current working directory\n", }, + + { "qpsol", 9, 3, builtin_qpsol, + "Solve nonlinear programs using Gill and Murray's QPSOL. Usage:\n\ +\n\ + [x, obj, info, lambda] = qpsol (x, H, c [, lb, ub] [, lb, A, ub])\n\ +\n\ + Groups of arguments surrounded in `[]' are optional, but\n\ + must appear in the same relative order shown above.", }, + + { "qr", 2, 2, builtin_qr, + "[q, r] = qr (X): form QR factorization of X\n", }, + + { "quad", 6, 3, builtin_quad, + "Integrate a nonlinear function of one variable using Quadpack.\n\ +Usage:\n\ +\n\ + [v, ier, nfun] = quad ('f', a, b [, tol] [, sing])\n\ +\n\ +Where the first argument is the name of the function to call to\n\ +compute the value of the integrand. It must have the form\n\ +\n\ + y = f (x) +\n\ +where y and x are scalars.\n\ +\n\ +The second and third arguments are limits of integration. Either or\n\ +both may be infinite. The optional argument tol specifies the desired\n\ +accuracy of the result. The optional argument sing is a vector of\n\ +at which the integrand is singular.\n\n", }, + + { "quit", 1, 0, builtin_quit, + "exit Octave gracefully\n", }, + + { "rand", 2, 1, builtin_rand, + "matrices with random elements\n", }, + + { "replot", 1, 0, builtin_replot, + "redisplay current plot\n", }, + + { "scanf", 2, -1, builtin_scanf, + "[a,b,c...] = scanf ('fmt')\n", }, + + { "setstr", 2, 1, builtin_setstr, + "setstr (v): convert a vector to a string\n", }, + + { "shell_cmd", 2, 1, builtin_shell_command, + "shell_cmd (string [, return_output]): execute shell commands\n", }, + + { "schur", 3, 2, builtin_schur, + "returns the Schur (straight or ordered) decomposition of matrix\n", }, + + { "size", 2, 1, builtin_size, + "size(X): return rows and columns of X\n", }, + + { "sort", 2, 2, builtin_sort, + "[s,i] = sort(x): sort the columns of x, optionally return sort index\n", }, + + { "sqrtm", 2, 1, builtin_sqrtm, + "Matrix sqrt, sqrt (A)\n", }, + + { "sprintf", -1, 1, builtin_sprintf, + "s = sprintf ('fmt', ...)\n", }, + + { "sscanf", 3, -1, builtin_sscanf, + "[a,b,c...] = sscanf (string, 'fmt')\n", }, + + { "sum", 2, 1, builtin_sum, + "sum (X): sum of elements\n", }, + + { "sumsq", 2, 1, builtin_sumsq, + "sumsq (X): sum of squares of elements\n", }, + + { "svd", 2, 3, builtin_svd, + "[U,S,V] = svd(X): return SVD of X\n", }, + + { "warranty", 1, 0, builtin_warranty, + "describe copying conditions\n", }, + + { "zeros", 3, 1, builtin_zeros, + "create a matrix of all zeros\n", }, + + { NULL, -1, -1, NULL, NULL, }, +}; + +// This is a lie. Some of these get reassigned to be numeric +// variables. See below. + +static builtin_string_variables string_variables[] = +{ + { "I", "??", NULL, + "sqrt (-1)\n", }, + + { "Inf", "??", NULL, + "infinity\n", }, + + { "J", "??", NULL, + "sqrt (-1)\n", }, + +#if defined (HAVE_ISNAN) + { "NaN", "??", NULL, + "not a number\n", }, +#endif + + { "LOADPATH", "??", sv_loadpath, + "colon separated list of directories to search for scripts\n", }, + + { "PAGER", "??", sv_pager_binary, + "path to pager binary\n", }, + + { "PS1", "\\s:\\#> ", sv_ps1, + "primary prompt string\n", }, + + { "PS2", "> ", sv_ps2, + "secondary prompt string\n", }, + + { "PWD", "??PWD??", sv_pwd, + "current working directory\n", }, + + { "SEEK_SET", "??", NULL, + "used with fseek to position file relative to the beginning\n", }, + + { "SEEK_CUR", "??", NULL, + "used with fseek to position file relative to the current position\n", }, + + { "SEEK_END", "??", NULL, + "used with fseek to position file relative to the end\n", }, + + { "do_fortran_indexing", "false", do_fortran_indexing, + "allow single indices for matrices\n", }, + + { "empty_list_elements_ok", "warn", empty_list_elements_ok, + "ignore the empty element in expressions like `a = [[], 1]'\n", }, + + { "eps", "??", NULL, + "machine precision\n", }, + + { "gnuplot_binary", "gnuplot", sv_gnuplot_binary, + "path to gnuplot binary\n", }, + + { "i", "??", NULL, + "sqrt (-1)\n", }, + + { "implicit_str_to_num_ok", "false", implicit_str_to_num_ok, + "allow implicit string to number conversion\n", }, + + { "inf", "??", NULL, + "infinity\n", }, + + { "j", "??", NULL, + "sqrt (-1)\n", }, + +#if defined (HAVE_ISNAN) + { "nan", "??", NULL, + "not a number\n", }, +#endif + + { "ok_to_lose_imaginary_part", "warn", ok_to_lose_imaginary_part, + "silently convert from complex to real by dropping imaginary part\n", }, + + { "output_max_field_width", "??", set_output_max_field_width, + "maximum width of an output field for numeric output\n", }, + + { "output_precision", "??", set_output_precision, + "number of significant figures to display for numeric output\n", }, + + { "page_screen_output", "true", page_screen_output, + "if possible, send output intended for the screen through the pager\n", }, + + { "pi", "??", NULL, + "ratio of the circumference of a circle to its diameter\n", }, + + { "prefer_column_vectors", "true", prefer_column_vectors, + "prefer column/row vectors\n", }, + + { "prefer_zero_one_indexing", "false", prefer_zero_one_indexing, + "when there is a conflict, prefer zero-one style indexing\n", }, + + { "print_answer_id_name", "true", print_answer_id_name, + "set output style to print `var_name = ...'\n", }, + + { "print_empty_dimensions", "true", print_empty_dimensions, + "also print dimensions of empty matrices\n", }, + + { "propagate_empty_matrices", "true", propagate_empty_matrices, + "operations on empty matrices return an empty matrix, not an error\n", }, + + { "resize_on_range_error", "true", resize_on_range_error, + "enlarge matrices on assignment\n", }, + + { "return_last_computed_value", "false", return_last_computed_value, + "if a function does not return any values explicitly, return the\n\ +last computed value\n", }, + + { "silent_functions", "false", silent_functions, + "suppress printing results in called functions\n", }, + + { "split_long_rows", "true", split_long_rows, + "split long matrix rows instead of wrapping\n", }, + + { "stdin", "??", NULL, + "file number of the standard input stream\n", }, + + { "stdout", "??", NULL, + "file number of the standard output stream\n", }, + + { "stderr", "??", NULL, + "file number of the standard error stream\n", }, + + { "treat_neg_dim_as_zero", "false", treat_neg_dim_as_zero, + "convert negative dimensions to zero\n", }, + + { "warn_assign_as_truth_value", "true", warn_assign_as_truth_value, + "produce warning for assignments used as truth values\n", }, + + { "warn_comma_in_global_decl", "true", warn_comma_in_global_decl, + "produce warning for commas in global declarations\n", }, + + { "warn_divide_by_zero", "true", warn_divide_by_zero, + "on IEEE machines, allow divide by zero errors to be suppressed\n", }, + + { NULL, NULL, NULL, NULL, }, +}; + +void +make_eternal (char *s) +{ + symbol_record *sym_rec = curr_sym_tab->lookup (s, 0, 0); + if (sym_rec != (symbol_record *) NULL) + sym_rec->make_eternal (); +} + +void +install_builtins (void) +{ + symbol_record *sym_rec; + + tree_builtin *tb_tmp; + +// So that the clear function can't delete other builtin variables and +// functions, they are given eternal life. + + builtin_mapper_functions *mfptr = mapper_functions; + while (mfptr->name != (char *) NULL) + { + sym_rec = curr_sym_tab->lookup (mfptr->name, 1); + sym_rec->unprotect (); + + Mapper_fcn mfcn; + mfcn.neg_arg_complex = mfptr->neg_arg_complex; + mfcn.d_d_mapper = mfptr->d_d_mapper; + mfcn.d_c_mapper = mfptr->d_c_mapper; + mfcn.c_c_mapper = mfptr->c_c_mapper; + + tb_tmp = new tree_builtin (mfptr->nargin_max, mfptr->nargout_max, + mfcn, sym_rec); + + sym_rec->define (tb_tmp); + sym_rec->document (mfptr->help_string); + sym_rec->make_eternal (); + sym_rec->protect (); + mfptr++; + } + + builtin_text_functions *tfptr = text_functions; + while (tfptr->name != (char *) NULL) + { + sym_rec = curr_sym_tab->lookup (tfptr->name, 1); + sym_rec->unprotect (); + + tb_tmp = new tree_builtin (tfptr->nargin_max, 1, + tfptr->text_fcn, sym_rec); + + sym_rec->define (tb_tmp); + sym_rec->document (tfptr->help_string); + sym_rec->make_eternal (); + sym_rec->protect (); + tfptr++; + } + + builtin_general_functions *gfptr = general_functions; + while (gfptr->name != (char *) NULL) + { + sym_rec = curr_sym_tab->lookup (gfptr->name, 1); + sym_rec->unprotect (); + + tb_tmp = new tree_builtin (gfptr->nargin_max, gfptr->nargout_max, + gfptr->general_fcn, sym_rec); + + sym_rec->define (tb_tmp); + sym_rec->document (gfptr->help_string); + sym_rec->make_eternal (); + sym_rec->protect (); + gfptr++; + } + +// Most built-in variables are not protected because the user should +// be able to redefine them. + + builtin_string_variables *svptr = string_variables; + while (svptr->name != (char *) NULL) + { + sym_rec = curr_sym_tab->lookup (svptr->name, 1); + sym_rec->unprotect (); + + tree_constant *tmp = new tree_constant (svptr->value); + + sym_rec->set_sv_function (svptr->sv_function); + sym_rec->define (tmp); + sym_rec->document (svptr->help_string); + sym_rec->make_eternal (); + svptr++; + } + +// XXX FIXME XXX -- Need a convenient way to document these variables. + +// IMPORTANT: Always create a new tree_constant for each variable. + + tree_constant *tmp = NULL_TREE_CONST; + bind_variable ("ans", tmp); + + Complex ctmp (0.0, 1.0); + tmp = new tree_constant (ctmp); + bind_protected_variable ("I", tmp); + make_eternal ("I"); + + tmp = new tree_constant (ctmp); + bind_protected_variable ("J", tmp); + make_eternal ("J"); + +// Let i and j be functions so they can be redefined without being +// wiped out. + + char *tmp_help; + + tmp = new tree_constant (ctmp); + sym_rec = curr_sym_tab->lookup ("i", 1); + tmp_help = sym_rec->help (); + sym_rec->define_as_fcn (tmp); + sym_rec->document (tmp_help); + sym_rec->protect (); + sym_rec->make_eternal (); + + tmp = new tree_constant (ctmp); + sym_rec = curr_sym_tab->lookup ("j", 1); + tmp_help = sym_rec->help (); + sym_rec->define_as_fcn (tmp); + sym_rec->document (tmp_help); + sym_rec->protect (); + sym_rec->make_eternal (); + + tmp = new tree_constant (get_working_directory ("initialize_globals")); + bind_protected_variable ("PWD", tmp); + make_eternal ("PWD"); + + tmp = new tree_constant (load_path); + bind_variable ("LOADPATH", tmp); + make_eternal ("LOADPATH"); + + tmp = new tree_constant (default_pager ()); + bind_variable ("PAGER", tmp); + make_eternal ("PAGER"); + + tmp = new tree_constant (0.0); + bind_variable ("SEEK_SET", tmp); + make_eternal ("SEEK_SET"); + + tmp = new tree_constant (1.0); + bind_variable ("SEEK_CUR", tmp); + make_eternal ("SEEK_CUR"); + + tmp = new tree_constant (2.0); + bind_variable ("SEEK_END", tmp); + make_eternal ("SEEK_END"); + + tmp = new tree_constant (DBL_EPSILON); + bind_protected_variable ("eps", tmp); + make_eternal ("eps"); + + tmp = new tree_constant (10.0); + bind_variable ("output_max_field_width", tmp); + make_eternal ("output_max_field_width"); + + tmp = new tree_constant (5.0); + bind_variable ("output_precision", tmp); + make_eternal ("output_precision"); + + tmp = new tree_constant (4.0 * atan (1.0)); + bind_protected_variable ("pi", tmp); + make_eternal ("pi"); + + tmp = new tree_constant (0.0); + bind_protected_variable ("stdin", tmp); + make_eternal ("stdin"); + + tmp = new tree_constant (1.0); + bind_protected_variable ("stdout", tmp); + make_eternal ("stdout"); + + tmp = new tree_constant (2.0); + bind_protected_variable ("stderr", tmp); + make_eternal ("stderr"); + +#if defined (HAVE_ISINF) || defined (HAVE_FINITE) +#ifdef linux + tmp = new tree_constant (HUGE_VAL); +#else + tmp = new tree_constant (1.0/0.0); +#endif + bind_protected_variable ("Inf", tmp); + make_eternal ("Inf"); + +#ifdef linux + tmp = new tree_constant (HUGE_VAL); +#else + tmp = new tree_constant (1.0/0.0); +#endif + bind_protected_variable ("inf", tmp); + make_eternal ("inf"); + +#else + +// This is sort of cheesy, but what can we do, other than blowing it +// off completely, or writing an entire IEEE emulation package? + + tmp = new tree_constant (DBL_MAX); + bind_protected_variable ("Inf", tmp); + make_eternal ("Inf"); + + tmp = new tree_constant (DBL_MAX); + bind_protected_variable ("inf", tmp); + make_eternal ("inf"); +#endif + +#if defined (HAVE_ISNAN) +#ifdef linux + tmp = new tree_constant (NAN); +#else + tmp = new tree_constant (0.0/0.0); +#endif + bind_protected_variable ("NaN", tmp); + make_eternal ("NaN"); + +#ifdef linux + tmp = new tree_constant (NAN); +#else + tmp = new tree_constant (0.0/0.0); +#endif + bind_protected_variable ("nan", tmp); + make_eternal ("nan"); +#endif +} + +int +is_text_function_name (char *s) +{ + int retval = 0; + + builtin_text_functions *tfptr = text_functions; + while (tfptr->name != (char *) NULL) + { + if (strcmp (tfptr->name, s) == 0) + { + retval = 1; + break; + } + tfptr++; + } + + return retval; +} + +help_list * +builtin_mapper_functions_help (void) +{ + int count = 0; + builtin_mapper_functions *mfptr; + + mfptr = mapper_functions; + while (mfptr->name != (char *) NULL) + { + count++; + mfptr++; + } + + if (count == 0) + return (help_list *) NULL; + + help_list *hl = new help_list [count+1]; + + int i = 0; + mfptr = mapper_functions; + while (mfptr->name != (char *) NULL) + { + hl[i].name = mfptr->name; + hl[i].help = mfptr->help_string; + i++; + mfptr++; + } + + hl[count].name = (char *) NULL; + hl[count].help = (char *) NULL; + + return hl; +} + +help_list * +builtin_general_functions_help (void) +{ + int count = 0; + builtin_general_functions *gfptr; + + gfptr = general_functions; + while (gfptr->name != (char *) NULL) + { + count++; + gfptr++; + } + + if (count == 0) + return (help_list *) NULL; + + help_list *hl = new help_list [count+1]; + + int i = 0; + gfptr = general_functions; + while (gfptr->name != (char *) NULL) + { + hl[i].name = gfptr->name; + hl[i].help = gfptr->help_string; + i++; + gfptr++; + } + + hl[count].name = (char *) NULL; + hl[count].help = (char *) NULL; + + return hl; +} + +help_list * +builtin_text_functions_help (void) +{ + int count = 0; + builtin_text_functions *tfptr; + + tfptr = text_functions; + while (tfptr->name != (char *) NULL) + { + count++; + tfptr++; + } + + if (count == 0) + return (help_list *) NULL; + + help_list *hl = new help_list [count+1]; + + int i = 0; + tfptr = text_functions; + while (tfptr->name != (char *) NULL) + { + hl[i].name = tfptr->name; + hl[i].help = tfptr->help_string; + i++; + tfptr++; + } + + hl[count].name = (char *) NULL; + hl[count].help = (char *) NULL; + + return hl; +} + +help_list * +builtin_variables_help (void) +{ + int count = 0; + builtin_string_variables *svptr; + + svptr = string_variables; + while (svptr->name != (char *) NULL) + { + count++; + svptr++; + } + + if (count == 0) + return (help_list *) NULL; + + help_list *hl = new help_list [count+1]; + + int i = 0; + svptr = string_variables; + while (svptr->name != (char *) NULL) + { + hl[i].name = svptr->name; + hl[i].help = svptr->help_string; + i++; + svptr++; + } + + hl[count].name = (char *) NULL; + hl[count].help = (char *) NULL; + + return hl; +} + +/* +;;; Local Variables: *** +;;; mode: C++ *** +;;; page-delimiter: "^/\\*" *** +;;; End: *** +*/
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/builtins.h Sun Aug 08 01:13:40 1993 +0000 @@ -0,0 +1,94 @@ +// Builtin function support. -*- C++ -*- +/* + +Copyright (C) 1992, 1993 John W. Eaton + +This file is part of Octave. + +Octave is free software; you can redistribute it and/or modify it +under the terms of the GNU General Public License as published by the +Free Software Foundation; either version 2, or (at your option) any +later version. + +Octave is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +for more details. + +You should have received a copy of the GNU General Public License +along with Octave; see the file COPYING. If not, write to the Free +Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. + +*/ + +#if !defined (_builtins_h) +#define _builtins_h 1 + +#ifdef __GNUG__ +#pragma interface +#endif + +#include <Complex.h> + +#include "help.h" + +#ifndef MAPPER_FCN_TYPEDEFS +#define MAPPER_FCN_TYPEDEFS 1 + +typedef double (*d_d_Mapper)(double); +typedef double (*d_c_Mapper)(const Complex&); +typedef Complex (*c_c_Mapper)(const Complex&); + +#endif + +struct Mapper_fcn +{ + int neg_arg_complex; + d_d_Mapper d_d_mapper; + d_c_Mapper d_c_mapper; + c_c_Mapper c_c_mapper; +}; + +struct builtin_mapper_functions +{ + char *name; + int nargin_max; + int nargout_max; + int neg_arg_complex; + d_d_Mapper d_d_mapper; + d_c_Mapper d_c_mapper; + c_c_Mapper c_c_mapper; + char *help_string; +}; + +#ifndef SV_FUNCTION_TYPEDEFS +#define SV_FUNCTION_TYPEDEFS 1 + +typedef int (*sv_Function)(void); + +#endif + +struct builtin_string_variables +{ + char *name; + char *value; + sv_Function sv_function; + char *help_string; +}; + +extern void install_builtins (void); +extern int is_text_function_name (char *s); + +extern help_list *builtin_mapper_functions_help (void); +extern help_list *builtin_general_functions_help (void); +extern help_list *builtin_text_functions_help (void); +extern help_list *builtin_variables_help (void); + +#endif + +/* +;;; Local Variables: *** +;;; mode: C++ *** +;;; page-delimiter: "^/\\*" *** +;;; End: *** +*/
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/colloc.cc Sun Aug 08 01:13:40 1993 +0000 @@ -0,0 +1,129 @@ +// tc-colloc.cc -*- C++ -*- +/* + +Copyright (C) 1993 John W. Eaton + +This file is part of Octave. + +Octave is free software; you can redistribute it and/or modify it +under the terms of the GNU General Public License as published by the +Free Software Foundation; either version 2, or (at your option) any +later version. + +Octave is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +for more details. + +You should have received a copy of the GNU General Public License +along with Octave; see the file COPYING. If not, write to the Free +Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. + +*/ + +#ifdef __GNUG__ +#pragma implementation +#endif + +#include "CollocWt.h" + +#include "tree-const.h" +#include "error.h" +#include "utils.h" + +#ifdef WITH_DLD +tree_constant * +builtin_colloc_2 (tree_constant *args, int nargin, int nargout) +{ + return collocation_weights (args, nargin); +} +#endif + +tree_constant * +collocation_weights (tree_constant *args, int nargin) +{ + tree_constant *retval = NULL_TREE_CONST; + + if (args[1].const_type () != tree_constant_rep::complex_scalar_constant + && args[1].const_type () != tree_constant_rep::scalar_constant) + { + message ("colloc", "first argument must be a scalar"); + return retval; + } + + int ncol = NINT (args[1].double_value ()); + if (ncol < 0) + { + message ("colloc", "first argument must be non-negative"); + return retval; + } + + int ntot = ncol; + int left = 0; + int right = 0; + + for (int i = 2; i < nargin; i++) + { + if (args[i].is_defined ()) + { + if (! args[i].is_string_type ()) + { + message ("colloc", "expecting string argument"); + return retval; + } + + char *s = args[i].string_value (); + if (s != (char *) NULL + && (((*s == 'R' || *s == 'r') && strlen (s) == 1) + || strcmp (s, "right") == 0)) + { + right = 1; + } + else if (s != (char *) NULL + && (((*s == 'L' || *s == 'l') && strlen (s) == 1) + || strcmp (s, "left") == 0)) + { + left = 1; + } + else + { + message ("colloc", "unrecognized argument"); + return retval; + } + } + else + { + message ("colloc", "unexpected NULL argument"); + return retval; + } + } + + ntot += left + right; + if (ntot < 1) + message ("colloc", "the total number of roots must be positive"); + + CollocWt wts (ncol, left, right); + + ColumnVector r = wts.roots (); + Matrix A = wts.first (); + Matrix B = wts.second (); + ColumnVector q = wts.quad_weights (); + + retval = new tree_constant [5]; + + retval[0] = tree_constant (r); + retval[1] = tree_constant (A); + retval[2] = tree_constant (B); + retval[3] = tree_constant (q); + retval[4] = tree_constant (); + + return retval; +} + +/* +;;; Local Variables: *** +;;; mode: C++ *** +;;; page-delimiter: "^/\\*" *** +;;; End: *** +*/ +
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/dassl.cc Sun Aug 08 01:13:40 1993 +0000 @@ -0,0 +1,159 @@ +// tc-dassl.cc -*- C++ -*- +/* + +Copyright (C) 1993 John W. Eaton + +This file is part of Octave. + +Octave is free software; you can redistribute it and/or modify it +under the terms of the GNU General Public License as published by the +Free Software Foundation; either version 2, or (at your option) any +later version. + +Octave is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +for more details. + +You should have received a copy of the GNU General Public License +along with Octave; see the file COPYING. If not, write to the Free +Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. + +*/ + +#ifdef __GNUG__ +#pragma implementation +#endif + +#include "DAE.h" + +#include "tree-const.h" +#include "variables.h" +#include "gripes.h" +#include "error.h" +#include "utils.h" + +// Global pointer for user defined function required by dassl. +static tree *dassl_fcn; + +#ifdef WITH_DLD +tree_constant * +builtin_dassl_2 (tree_constant *args, int nargin, int nargout) +{ + return dassl (args, nargin, nargout); +} +#endif + +ColumnVector +dassl_user_function (const ColumnVector& x, const ColumnVector& xdot, double t) +{ + ColumnVector retval; + + int nstates = x.capacity (); + + assert (nstates == xdot.capacity ()); + +// tree_constant name (dassl_fcn->name ()); + tree_constant *args = new tree_constant [4]; +// args[0] = name; + args[3] = tree_constant (t); + + if (nstates > 1) + { + Matrix m1 (nstates, 1); + Matrix m2 (nstates, 1); + for (int i = 0; i < nstates; i++) + { + m1 (i, 0) = x.elem (i); + m2 (i, 0) = xdot.elem (i); + } + tree_constant state (m1); + tree_constant deriv (m2); + args[1] = state; + args[2] = deriv; + } + else + { + double d1 = x.elem (0); + double d2 = xdot.elem (0); + tree_constant state (d1); + tree_constant deriv (d2); + args[1] = state; + args[2] = deriv; + } + + if (dassl_fcn != NULL_TREE) + { + tree_constant *tmp = dassl_fcn->eval (args, 4, 1, 0); + delete [] args; + if (tmp != NULL_TREE_CONST && tmp[0].is_defined ()) + { + retval = tmp[0].to_vector (); + delete [] tmp; + } + else + { + delete [] tmp; + gripe_user_supplied_eval ("dassl"); + jump_to_top_level (); + } + } + + return retval; +} + +tree_constant * +dassl (tree_constant *args, int nargin, int nargout) +{ +// Assumes that we have been given the correct number of arguments. + + tree_constant *retval = NULL_TREE_CONST; + + dassl_fcn = is_valid_function (args[1], "dassl", 1); + if (dassl_fcn == NULL_TREE + || takes_correct_nargs (dassl_fcn, 4, "dassl", 1) != 1) + return retval; + + ColumnVector state = args[2].to_vector (); + ColumnVector deriv = args[3].to_vector (); + ColumnVector out_times = args[4].to_vector (); + ColumnVector crit_times; + int crit_times_set = 0; + if (nargin > 5) + { + crit_times = args[5].to_vector (); + crit_times_set = 1; + } + + if (state.capacity () != deriv.capacity ()) + { + message ("dassl", "x and xdot must have the same size"); + return retval; + } + + double tzero = out_times.elem (0); + + DAEFunc func (dassl_user_function); + DAE dae (state, deriv, tzero, func); + + Matrix output; + Matrix deriv_output; + + if (crit_times_set) + output = dae.integrate (out_times, deriv_output, crit_times); + else + output = dae.integrate (out_times, deriv_output); + + retval = new tree_constant [3]; + retval[0] = tree_constant (output); + retval[1] = tree_constant (deriv_output); + return retval; +} + +/* +;;; Local Variables: *** +;;; mode: C++ *** +;;; page-delimiter: "^/\\*" *** +;;; End: *** +*/ +
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/det.cc Sun Aug 08 01:13:40 1993 +0000 @@ -0,0 +1,135 @@ +// tc-det.cc -*- C++ -*- +/* + +Copyright (C) 1993 John W. Eaton + +This file is part of Octave. + +Octave is free software; you can redistribute it and/or modify it +under the terms of the GNU General Public License as published by the +Free Software Foundation; either version 2, or (at your option) any +later version. + +Octave is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +for more details. + +You should have received a copy of the GNU General Public License +along with Octave; see the file COPYING. If not, write to the Free +Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. + +*/ + +#ifdef __GNUG__ +#pragma implementation +#endif + +#include "Matrix.h" + +#include "tree-const.h" +#include "user-prefs.h" +#include "gripes.h" +#include "error.h" + +#ifdef WITH_DLD +tree_constant * +builtin_det_2 (tree_constant *args, int nargin, int nargout) +{ + tree_constant *retval = new tree_constant [2]; + retval[0] = determinant (args[1]); + return retval; +} +#endif + +tree_constant +determinant (tree_constant& a) +{ + tree_constant retval; + + tree_constant tmp = a.make_numeric ();; + + int nr = tmp.rows (); + int nc = tmp.columns (); + if (nr == 0 || nc == 0) + { + int flag = user_pref.propagate_empty_matrices; + if (flag < 0) + gripe_empty_arg ("det", 0); + else if (flag == 0) + gripe_empty_arg ("det", 1); + } + + if (nr == 0 && nc == 0) + return tree_constant (1.0); + + switch (tmp.const_type ()) + { + case tree_constant_rep::matrix_constant: + { + Matrix m = tmp.matrix_value (); + if (m.rows () == m.columns ()) + { + int info; + double rcond = 0.0; + DET det = m.determinant (info, rcond); + if (info == -1) + message ("det", + "matrix singular to machine precision, rcond = %g", + rcond); + else + { + double d = det.value (); + retval = tree_constant (d); + } + } + else + gripe_square_matrix_required ("det"); + } + break; + case tree_constant_rep::complex_matrix_constant: + { + ComplexMatrix m = tmp.complex_matrix_value (); + if (m.rows () == m.columns ()) + { + int info; + double rcond = 0.0; + ComplexDET det = m.determinant (info, rcond); + if (info == -1) + message ("det", + "matrix singular to machine precision, rcond = %g", + rcond); + else + { + Complex c = det.value (); + retval = tree_constant (c); + } + } + else + gripe_square_matrix_required ("det"); + } + break; + case tree_constant_rep::scalar_constant: + { + double d = tmp.double_value (); + retval = tree_constant (d); + } + break; + case tree_constant_rep::complex_scalar_constant: + { + Complex c = tmp.complex_value (); + retval = tree_constant (c); + } + break; + default: + break; + } + return retval; +} + +/* +;;; Local Variables: *** +;;; mode: C++ *** +;;; page-delimiter: "^/\\*" *** +;;; End: *** +*/
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/dynamic-ld.cc Sun Aug 08 01:13:40 1993 +0000 @@ -0,0 +1,164 @@ +// dynamic-ld.cc -*- C++ -*- +/* + +Copyright (C) 1993 John W. Eaton + +This file is part of Octave. + +Octave is free software; you can redistribute it and/or modify it +under the terms of the GNU General Public License as published by the +Free Software Foundation; either version 2, or (at your option) any +later version. + +Octave is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +for more details. + +You should have received a copy of the GNU General Public License +along with Octave; see the file COPYING. If not, write to the Free +Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. + +*/ + +#ifdef __GNUG__ +#pragma implementation +#endif + +extern "C" +{ +#include "dld.h" +} + +#include "dynamic-ld.h" +#include "tree-const.h" +#include "user-prefs.h" +#include "octave.h" +#include "utils.h" +#include "error.h" + +void +octave_dld_tc2_unlink_by_symbol (char *name, int hard = 1) +{ + char *mangled_fcn_name = strconcat (name, "__FP13tree_constantii"); + int status = dld_unlink_by_symbol (mangled_fcn_name, hard); + if (status != 0) + dld_perror ("octave_dld_tc2_unlink_by_symbol"); + delete [] mangled_fcn_name; +} + +void +octave_dld_tc2_unlink_by_file (char *name, int hard = 1) +{ + int status = dld_unlink_by_file (name, hard); + if (status != 0) + dld_perror ("octave_dld_tc2_unlink_by_file"); +} + +static void +octave_dld_init (void) +{ + static int initialized = 0; + + if (! initialized) + { + char *full_path = dld_find_executable (raw_prog_name); + if (full_path != (char *) NULL) + { + int status = dld_init (full_path); + if (status != 0) + { + dld_perror ("octave_dld_tc2_and_go"); + error ("failed to load symbols from `%s'", full_path); + } + else + initialized = 1; + } + else + error ("octave_dld_tc2_and_go: can't find full path to `%s'", + prog_name); + } +} + +/* + * Look for object in path. It should provide a definition for the + * function we just marked as undefined. If we find it, we\'ll also + * try to load the remaining undefined symbols. + */ +static int +octave_dld_link (char *object) +{ + char *file = file_in_path (object, (char *) NULL); + int status = dld_link (file); + if (status != 0) + dld_perror ("octave_dld_link"); + + delete [] file; + return status; +} + +int +octave_dld_tc2_link (char *object) +{ + int status = octave_dld_link (object); + if (status == 0) + { + status = octave_dld_link ("liboctave.a"); + if (status == 0) + octave_dld_link ("libcruft.a"); + } + return status; +} + +builtin_fcn_ptr +octave_dld_tc2 (char *name, char *fcn, char *object) +{ + builtin_fcn_ptr retval = (builtin_fcn_ptr) NULL; + + octave_dld_init (); + + char *mangled_fcn_name = strconcat (fcn, "__FP13tree_constantii"); + +// See if the function has already been loaded. If not, mark it as +// undefined. + + if (dld_get_func (mangled_fcn_name) == 0) + dld_create_reference (mangled_fcn_name); + + int status = octave_dld_link (object); + if (status == 0) + { +// Return a pointer to the function we just loaded. If we can\'t find +// it, this will return NULL. + + retval = (builtin_fcn_ptr) dld_get_func (mangled_fcn_name); + } + + delete [] mangled_fcn_name; + + return retval; + +} + +tree_constant * +octave_dld_tc2_and_go (tree_constant *args, int nargin, int nargout, + char *name, char *fcn, char *object) +{ + tree_constant *retval = NULL_TREE_CONST; + + builtin_fcn_ptr fcn_to_call = octave_dld_tc2 (name, fcn, object); + + if (fcn_to_call != (builtin_fcn_ptr) NULL) + retval = (*fcn_to_call) (args, nargin, nargout); + else + error ("octave_dld_tc2_and_go: failed to load `%s'", name); + + return retval; +} + +/* +;;; Local Variables: *** +;;; mode: C++ *** +;;; page-delimiter: "^/\\*" *** +;;; End: *** +*/
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/dynamic-ld.h Sun Aug 08 01:13:40 1993 +0000 @@ -0,0 +1,53 @@ +// dynamic-ld.h -*- C++ -*- +/* + +Copyright (C) 1993 John W. Eaton + +This file is part of Octave. + +Octave is free software; you can redistribute it and/or modify it +under the terms of the GNU General Public License as published by the +Free Software Foundation; either version 2, or (at your option) any +later version. + +Octave is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +for more details. + +You should have received a copy of the GNU General Public License +along with Octave; see the file COPYING. If not, write to the Free +Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. + +*/ + +#if !defined (_dynamic_ld_h) +#define _dynamic_ld_h 1 + +#ifdef __GNUG__ +#pragma interface +#endif + +class tree_constant; + +typedef tree_constant* (*builtin_fcn_ptr) (tree_constant*, int, int); + +extern void octave_dld_tc2_unlink_by_symbol (char *name, int hard = 1); + +extern void octave_dld_tc2_unlink_by_file (char *name, int hard = 1); + +extern builtin_fcn_ptr octave_dld_tc2 (char *name, char *fcn, char *object); + +extern tree_constant *octave_dld_tc2_and_go (tree_constant *args, + int nargin, int nargout, + char *name, char *fcn, + char *object); + +#endif + +/* +;;; Local Variables: *** +;;; mode: C++ *** +;;; page-delimiter: "^/\\*" *** +;;; End: *** +*/
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/eig.cc Sun Aug 08 01:13:40 1993 +0000 @@ -0,0 +1,129 @@ +// tc-eig.cc -*- C++ -*- +/* + +Copyright (C) 1993 John W. Eaton + +This file is part of Octave. + +Octave is free software; you can redistribute it and/or modify it +under the terms of the GNU General Public License as published by the +Free Software Foundation; either version 2, or (at your option) any +later version. + +Octave is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +for more details. + +You should have received a copy of the GNU General Public License +along with Octave; see the file COPYING. If not, write to the Free +Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. + +*/ + +#ifdef __GNUG__ +#pragma implementation +#endif + +#include "Matrix.h" + +#include "tree-const.h" +#include "user-prefs.h" +#include "gripes.h" +#include "error.h" + +#ifdef WITH_DLD +tree_constant * +builtin_eig (tree_constant *args, int nargin, int nargout) +{ + return eig (args, nargin, nargout); +} +#endif + +tree_constant * +eig (tree_constant *args, int nargin, int nargout) +{ + tree_constant *retval = NULL_TREE_CONST; + + tree_constant arg = args[1].make_numeric (); + + int a_nr = arg.rows (); + int a_nc = arg.columns (); + + if (a_nr == 0 || a_nc == 0) + { + int flag = user_pref.propagate_empty_matrices; + if (flag != 0) + { + if (flag < 0) + gripe_empty_arg ("eig", 0); + Matrix m; + retval = new tree_constant [3]; + retval[0] = tree_constant (m); + retval[1] = tree_constant (m); + } + else + gripe_empty_arg ("eig", 1); + + return retval; + } + + if (a_nr != a_nc) + { + gripe_square_matrix_required ("eig"); + return retval; + } + + Matrix tmp; + ComplexMatrix ctmp; + EIG result; + switch (arg.const_type ()) + { + case tree_constant_rep::scalar_constant: + tmp.resize (1, 1); + tmp.elem (0, 0) = arg.double_value (); + result = EIG (tmp); + break; + case tree_constant_rep::matrix_constant: + tmp = arg.matrix_value (); + result = EIG (tmp); + break; + case tree_constant_rep::complex_scalar_constant: + ctmp.resize (1, 1); + ctmp.elem (0, 0) = arg.complex_value (); + result = EIG (ctmp); + break; + case tree_constant_rep::complex_matrix_constant: + ctmp = arg.complex_matrix_value (); + result = EIG (ctmp); + break; + default: + panic_impossible (); + break; + } + + if (nargout == 1) + { + retval = new tree_constant [2]; + retval[0] = tree_constant (result.eigenvalues (), 1); + } + else + { +// Blame it on Matlab. + + ComplexDiagMatrix d (result.eigenvalues ()); + + retval = new tree_constant [3]; + retval[0] = tree_constant (result.eigenvectors ()); + retval[1] = tree_constant (d); + } + + return retval; +} + +/* +;;; Local Variables: *** +;;; mode: C++ *** +;;; page-delimiter: "^/\\*" *** +;;; End: *** +*/
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/error.cc Sun Aug 08 01:13:40 1993 +0000 @@ -0,0 +1,96 @@ +// error.cc -*- C++ -*- +/* + +Copyright (C) 1992, 1993 John W. Eaton + +This file is part of Octave. + +Octave is free software; you can redistribute it and/or modify it +under the terms of the GNU General Public License as published by the +Free Software Foundation; either version 2, or (at your option) any +later version. + +Octave is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +for more details. + +You should have received a copy of the GNU General Public License +along with Octave; see the file COPYING. If not, write to the Free +Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. + +*/ + +#ifdef __GNUG__ +#pragma implementation +#endif + +#include <stdio.h> +#include <stdlib.h> +#include <stdarg.h> + +#include "error.h" + +static void +verror (const char *name, const char *fmt, va_list args) +{ + if (name != (char *) NULL) + fprintf (stderr, "%s: ", name); + + vfprintf (stderr, fmt, args); + fprintf (stderr, "\n"); + fflush (stderr); +} + +void +message (const char *name, const char *fmt, ...) +{ + va_list args; + va_start (args, fmt); + verror (name, fmt, args); + va_end (args); +} + +void +usage (const char *fmt, ...) +{ + va_list args; + va_start (args, fmt); + verror ("usage", fmt, args); + va_end (args); +} + +void +warning (const char *fmt, ...) +{ + va_list args; + va_start (args, fmt); + verror ("warning", fmt, args); + va_end (args); +} + +void +error (const char *fmt, ...) +{ + va_list args; + va_start (args, fmt); + verror ("error", fmt, args); + va_end (args); +} + +void +panic (const char *fmt, ...) +{ + va_list args; + va_start (args, fmt); + verror ("panic", fmt, args); + va_end (args); + abort (); +} + +/* +;;; Local Variables: *** +;;; mode: C++ *** +;;; page-delimiter: "^/\\*" *** +;;; End: *** +*/
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/error.h Sun Aug 08 01:13:40 1993 +0000 @@ -0,0 +1,48 @@ +// error.h -*- C++ -*- +/* + +Copyright (C) 1992, 1993 John W. Eaton + +This file is part of Octave. + +Octave is free software; you can redistribute it and/or modify it +under the terms of the GNU General Public License as published by the +Free Software Foundation; either version 2, or (at your option) any +later version. + +Octave is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +for more details. + +You should have received a copy of the GNU General Public License +along with Octave; see the file COPYING. If not, write to the Free +Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. + +*/ + +#if !defined (_error_h) +#define _error_h 1 + +#ifdef __GNUG__ +#pragma interface +#endif + +#define panic_impossible() \ + panic ("impossible state reached in file `%s' at line %d", \ + __FILE__, __LINE__) + +extern void message (const char *name, const char *fmt, ...); +extern void usage (const char *fmt, ...); +extern void warning (const char *fmt, ...); +extern void error (const char *fmt, ...); +extern void panic (const char *fmt, ...); + +#endif + +/* +;;; Local Variables: *** +;;; mode: C++ *** +;;; page-delimiter: "^/\\*" *** +;;; End: *** +*/
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/fft.cc Sun Aug 08 01:13:40 1993 +0000 @@ -0,0 +1,100 @@ +// tc-fft.cc -*- C++ -*- +/* + +Copyright (C) 1993 John W. Eaton + +This file is part of Octave. + +Octave is free software; you can redistribute it and/or modify it +under the terms of the GNU General Public License as published by the +Free Software Foundation; either version 2, or (at your option) any +later version. + +Octave is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +for more details. + +You should have received a copy of the GNU General Public License +along with Octave; see the file COPYING. If not, write to the Free +Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. + +*/ + +#ifdef __GNUG__ +#pragma implementation +#endif + +#include "Matrix.h" + +#include "tree-const.h" +#include "user-prefs.h" +#include "gripes.h" +#include "error.h" + +#ifdef WITH_DLD +tree_constant * +builtin_fft_2 (tree_constant *args, int nargin, int nargout) +{ + tree_constant *retval = new tree_constant [2]; + retval[0] = fft (args[1]); + return retval; +} +#endif + +tree_constant +fft (tree_constant& a) +{ + tree_constant retval; + + tree_constant tmp = a.make_numeric ();; + + if (tmp.rows () == 0 || tmp.columns () == 0) + { + int flag = user_pref.propagate_empty_matrices; + if (flag != 0) + { + if (flag < 0) + gripe_empty_arg ("fft", 0); + Matrix m; + retval = tree_constant (m); + } + else + gripe_empty_arg ("fft", 1); + + return retval; + } + + switch (tmp.const_type ()) + { + case tree_constant_rep::matrix_constant: + { + Matrix m = tmp.matrix_value (); + ComplexMatrix mfft = m.fourier (); + retval = tree_constant (mfft); + } + break; + case tree_constant_rep::complex_matrix_constant: + { + ComplexMatrix m = tmp.complex_matrix_value (); + ComplexMatrix mfft = m.fourier (); + retval = tree_constant (mfft); + } + break; + case tree_constant_rep::scalar_constant: + case tree_constant_rep::complex_scalar_constant: + error ("fft: invalid scalar argument"); + break; + default: + panic_impossible (); + break; + } + return retval; +} + +/* +;;; Local Variables: *** +;;; mode: C++ *** +;;; page-delimiter: "^/\\*" *** +;;; End: *** +*/
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/file-io.cc Sun Aug 08 01:13:40 1993 +0000 @@ -0,0 +1,1204 @@ +// file-io.cc -*- C++ -*- +/* + +Copyright (C) 1993 John W. Eaton + +This file is part of Octave. + +Octave is free software; you can redistribute it and/or modify it +under the terms of the GNU General Public License as published by the +Free Software Foundation; either version 2, or (at your option) any +later version. + +Octave is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +for more details. + +You should have received a copy of the GNU General Public License +along with Octave; see the file COPYING. If not, write to the Free +Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. + +*/ + +// Written by John C. Campbell <jcc@che.utexas.edu>. + +#ifdef __GNUG__ +#pragma implementation +#endif + +#include <DLList.h> +#include <unistd.h> +#include <string.h> +#include <stdio.h> +#include <stdlib.h> +#include <strstream.h> +#include <ctype.h> + +#include "statdefs.h" +#include "file-io.h" +#include "input.h" +#include "octave-hist.h" +#include "tree-const.h" +#include "error.h" +#include "utils.h" +#include "pager.h" + +// keeps a count of how many files are open and in the file list +static int file_count = 0; + +// keeps a count of args sent to printf or scanf +static int fmt_arg_count = 0; + +class File_info +{ + public: + File_info (void); + File_info (int num, char *nm, FILE *t, char *md); + File_info (const File_info& f); + + File_info& operator = (const File_info& f); + + ~File_info (void); + + int number (void) const; + char *name (void) const; + FILE *fptr (void) const; + char *mode (void) const; + + private: + int _number; + char *_name; + FILE *_fptr; + char *_mode; +}; + +File_info::File_info (void) +{ + _number = -1; + _name = (char *) NULL; + _fptr = (FILE *) NULL; + _mode = (char *) NULL; +} + +File_info::File_info (const File_info& f) +{ + _number = f._number; + _name = strsave (f._name); + _fptr = f._fptr; + _mode = strsave (f._mode); +} + +File_info& +File_info::operator = (const File_info& f) +{ + _number = f._number; + _name = strsave (f._name); + _fptr = f._fptr; + _mode = strsave (f._mode); + + return *this; +} + +File_info::~File_info (void) +{ + delete [] _name; + delete [] _mode; +} + +File_info::File_info (int n, char *nm, FILE *t, char *md) +{ + _number = n; + _name = strsave (nm); + _fptr = t; + _mode = strsave (md); +} + +int +File_info::number (void) const +{ + return _number; +} + +char * +File_info::name (void) const +{ + return _name; +} + +FILE * +File_info::fptr (void) const +{ + return _fptr; +} + +char * +File_info::mode (void) const +{ + return _mode; +} + + +// double linked list containing relevant information about open files +static DLList <File_info> file_list; + +void +initialize_file_io () +{ + File_info _stdin (0, "stdin", stdin, "r"); + File_info _stdout (1, "stdout", stdout, "w"); + File_info _stderr (2, "stderr", stderr, "w"); + + file_list.append (_stdin); + file_list.append (_stdout); + file_list.append (_stderr); + + file_count = 3; +} + +Pix +return_valid_file (tree_constant& arg) +{ + if (arg.is_string_type ()) + { + Pix p = file_list.first (); + File_info file; + for (int i = 0; i < file_count; i++) + { + char *file_name = arg.string_value (); + file = file_list (p); + if (strcmp (file.name (), file_name) == 0) + return p; + file_list.next (p); + } + } + else if (arg.is_scalar_type ()) + { + double file_num = arg.double_value (); + if ((double) NINT (file_num) != file_num) + error ("file number not an integer value"); + else + { + Pix p = file_list.first (); + File_info file; + for (int i = 0; i < file_count; i++) + { + file = file_list (p); + if (file.number () == file_num) + return p; + file_list.next (p); + } + error ("no file with that number"); + } + } + else + error ("inapproriate file specifier"); + + return (Pix) NULL; +} + +static Pix +fopen_file_for_user (tree_constant& arg, char *mode) +{ + char *file_name = arg.string_value (); + + FILE *file_ptr = fopen (file_name, mode); + if (file_ptr != (FILE *) NULL) + { + File_info file (++file_count, file_name, file_ptr, mode); + file_list.append (file); + + Pix p = file_list.first (); + File_info file_from_list; + + for (int i = 0; i < file_count; i++) + { + file_from_list = file_list (p); + if (strcmp (file_from_list.name (), file_name) == 0) + return p; + file_list.next (p); + } + } + + error ("problems automatically opening file for user"); + return (Pix) NULL; +} + + +tree_constant * +fclose_internal (tree_constant *args) +{ + tree_constant *retval = NULL_TREE_CONST; + + Pix p = return_valid_file (args[1]); + + if (p == (Pix) NULL) + return retval; + + File_info file = file_list (p); + + if (file.number () < 3) + { + warning ("fclose: can't close stdin, stdout, or stderr!"); + return retval; + } + + int success = fclose (file.fptr ()); + file_list.del (p); + file_count--; + + retval = new tree_constant[2]; + if (success == 0) + retval[0] = tree_constant (1.0); // succeeded + else + { + error ("fclose: error on closing file"); + retval[0] = tree_constant (0.0); // failed + } + + return retval; +} + +tree_constant * +fflush_internal (tree_constant *args) +{ + tree_constant *retval = NULL_TREE_CONST; + + Pix p = return_valid_file (args[1]); + + if (p == (Pix) NULL) + return retval; + + File_info file = file_list (p); + + if (strcmp (file.mode (), "r") == 0) + { + warning ("can't flush an input stream"); + return retval; + } + + int success = 0; + if (file.number () == 1) + flush_output_to_pager (); + else + success = fflush (file.fptr ()); + + retval = new tree_constant[2]; + if (success == 0) + retval[0] = tree_constant (1.0); // succeeded + else + { + error ("fflush: write error"); + retval[0] = tree_constant (0.0); // failed + } + + return retval; +} + +static int +valid_mode (char *mode) +{ + if (mode != (char *) NULL) + { + char m = mode[0]; + if (m == 'r' || m == 'w' || m == 'a') + { + m = mode[1]; + return (m == '\0' || (m == '+' && mode[2] == '\0')); + } + } + return 0; +} + +tree_constant * +fgets_internal (tree_constant *args, int nargout) +{ + tree_constant *retval = NULL_TREE_CONST; + + Pix p = return_valid_file (args[1]); + + if (p == (Pix) NULL) + { + if (args[1].is_string_type ()) + { + struct stat buffer; + char *name = args[1].string_value (); + if (stat (name, &buffer) == 0 + && (buffer.st_mode & S_IFREG) == S_IFREG) + { + p = fopen_file_for_user (args[1], "r"); + } + else + { + error ("fgets: file dosen't exist"); + return retval; + } + } + else + return retval; + } + + int length = 0; + + if (args[2].is_scalar_type ()) + { + length = (int) args[2].double_value (); + if ((double) NINT (length) != length) + { + error ("fgets: length not an integer value"); + return retval; + } + } + + char string[length+1]; + File_info file = file_list (p); + char *success = fgets (string, length+1, file.fptr ()); + + if (success == (char *) NULL) + { + retval = new tree_constant[2]; + retval[0] = tree_constant (-1.0); + return retval; + } + + if (nargout == 2) + { + retval = new tree_constant[3]; + retval[1] = tree_constant ((double) strlen (string)); + } + else + retval = new tree_constant[2]; + + retval[0] = tree_constant (string); + + return retval; +} + +tree_constant * +fopen_internal (tree_constant *args) +{ + tree_constant *retval = NULL_TREE_CONST; + Pix p; + + if (! args[1].is_string_type ()) + { + error ("fopen: file name must be a string"); + return retval; + } + + p = return_valid_file (args[1]); + + if (p != (Pix) NULL) + { + File_info file = file_list (p); + + retval = new tree_constant[2]; + retval[0] = tree_constant ((double) file.number ()); + + return retval; + } + + if (! args[2].is_string_type ()) + { + error ("fopen: mode must be a string"); + return retval; + } + + char *name = args[1].string_value (); + char *mode = args[2].string_value (); + + if (! valid_mode (mode)) + { + error ("fopen: invalid mode"); + return retval; + } + + struct stat buffer; + if (stat (name, &buffer) == 0 && (buffer.st_mode & S_IFDIR) == S_IFDIR) + { + error ("fopen: can't open directory"); + return retval; + } + + FILE *file_ptr = fopen (name, mode); + + if (file_ptr == (FILE *) NULL) + { + error ("fopen: file does not exist"); + return retval; + } + + int number = file_count++; + + File_info file (number, name, file_ptr, mode); + file_list.append (file); + + retval = new tree_constant[2]; + retval[0] = tree_constant ((double) number); + + return retval; +} + +tree_constant * +freport_internal () +{ + tree_constant *retval = NULL_TREE_CONST; + Pix p = file_list.first (); + + ostrstream output_buf; + + output_buf << "\n number mode name\n\n"; + for (int i = 0; i < file_count; i++) + { + File_info file = file_list (p); + output_buf.form ("%7d%6s %s\n", file.number (), file.mode (), + file.name ()); + file_list.next (p); + } + + output_buf << "\n" << ends; + maybe_page_output (output_buf); + + return retval; +} + +tree_constant * +frewind_internal (tree_constant *args) +{ + tree_constant *retval = NULL_TREE_CONST; + + Pix p = return_valid_file (args[1]); + if (p == (Pix) NULL) + p = fopen_file_for_user (args[1], "a+"); + + File_info file = file_list (p); + rewind (file.fptr ()); + + return retval; +} + +tree_constant * +fseek_internal (tree_constant *args, int nargin) +{ + tree_constant *retval = NULL_TREE_CONST; + + Pix p = return_valid_file (args[1]); + + if (p == (Pix) NULL) + p = fopen_file_for_user (args[1], "a+"); + + long origin = SEEK_SET; + long offset = 0; + if (args[2].is_scalar_type ()) + { + offset = (long) args[2].double_value (); + if ((double) NINT (offset) != offset) + { + error ("fseek: offset not an integer value"); + return retval; + } + } + + if (nargin == 4 && args[3].is_scalar_type ()) + { + origin = (long) args[3].double_value (); + if (origin == -1) + origin = SEEK_CUR; + else if (origin == -2) + origin = SEEK_END; + else + { + if ((double) NINT (origin) != origin) + { + error ("fseek: origin not an integer value"); + return retval; + } + } + } + + File_info file = file_list (p); + int success = fseek (file.fptr (), offset, origin); + retval = new tree_constant[2]; + + if (success == 0) + retval[0] = tree_constant (1.0); // succeeded + else + { + error ("fseek: file error"); + retval[0] = tree_constant (0.0); // failed + } + + return retval; +} + +tree_constant * +ftell_internal (tree_constant *args) +{ + tree_constant *retval = NULL_TREE_CONST; + Pix p = return_valid_file (args[1]); + + if (p == (Pix) NULL) + p = fopen_file_for_user (args[1], "a+"); + + File_info file = file_list (p); + long offset = ftell (file.fptr ()); + retval = new tree_constant[2]; + retval[0] = tree_constant ((double) offset); + + if (offset == -1L) + error ("ftell: write error"); + + return retval; +} + +void +close_files () +{ + Pix p = file_list.first (); + + for (int i = 0; i < file_count; i++) + { + File_info file = file_list (p); + if (i > 2) // do not close stdin, stdout, stderr! + { + int success = fclose (file.fptr ()); + if (success != 0) + error ("closing %s", file.name ()); + } + file_list.del (p); + } +} + +static int +process_printf_format (char *s, tree_constant *args, ostrstream& sb, + char *type, int nargin) +{ + ostrstream fmt; + + fmt << "%"; // do_printf() already blew past this one... + + tree_constant_rep::constant_type arg_type; + + int chars_from_fmt_str = 0; + + again: + switch (*s) + { + case '+': case '-': case ' ': case '0': case '#': + chars_from_fmt_str++; + fmt << *s++; + goto again; + + case '\0': + goto invalid_format; + + default: + break; + } + + if (*s == '*') + { + if (fmt_arg_count >= nargin) + { + message (type, "not enough arguments"); + return -1; + } + + if (args[fmt_arg_count].const_type () + != tree_constant_rep::scalar_constant) + { + message (type, "`*' must be replaced by an integer"); + return -1; + } + + fmt << (int) (args[fmt_arg_count++].double_value ()); + s++; + chars_from_fmt_str++; + } + else + { + while (*s != '\0' && isdigit (*s)) + { + chars_from_fmt_str++; + fmt << *s++; + } + } + + if (*s == '\0') + goto invalid_format; + + if (*s == '.') + { + chars_from_fmt_str++; + fmt << *s++; + } + + if (*s == '*') + { + if (*(s-1) == '*') + goto invalid_format; + + if (fmt_arg_count >= nargin) + { + message (type, "not enough arguments"); + return -1; + } + + if (args[fmt_arg_count].const_type () + != tree_constant_rep::scalar_constant) + { + message (type, "`*' must be replaced by an integer"); + return -1; + } + + fmt << (int) (args[fmt_arg_count++].double_value ()); + s++; + chars_from_fmt_str++; + } + else + { + while (*s != '\0' && isdigit (*s)) + { + chars_from_fmt_str++; + fmt << *s++; + } + } + + if (*s == '\0') + goto invalid_format; + + if (*s != '\0' && (*s == 'h' || *s == 'l' || *s == 'L')) + { + chars_from_fmt_str++; + fmt << *s++; + } + + if (*s == '\0') + goto invalid_format; + + if (fmt_arg_count >= nargin) + { + message (type, "not enough arguments"); + return -1; + } + + arg_type = args[fmt_arg_count].const_type (); + + switch (*s) + { + case 'd': case 'i': case 'o': case 'u': case 'x': case 'X': + + if (arg_type != tree_constant_rep::scalar_constant) + goto invalid_conversion; + else + { + chars_from_fmt_str++; + fmt << *s << ends; + double d = args[fmt_arg_count++].double_value (); + if ((int) d != d) + goto invalid_conversion; + else + { + char *s = fmt.str (); + sb.form (s, (int) d); + delete [] s; + return chars_from_fmt_str; + } + } + + case 'e': case 'E': case 'f': case 'g': case 'G': + + if (arg_type != tree_constant_rep::scalar_constant) + goto invalid_conversion; + else + { + chars_from_fmt_str++; + fmt << *s << ends; + char *s = fmt.str (); + sb.form (s, args[fmt_arg_count++].double_value ()); + delete [] s; + return chars_from_fmt_str; + } + + case 's': + + if (arg_type != tree_constant_rep::string_constant) + goto invalid_conversion; + else + { + chars_from_fmt_str++; + fmt << *s << ends; + char *s = fmt.str (); + sb.form (s, args[fmt_arg_count++].string_value ()); + delete [] s; + return chars_from_fmt_str; + } + + case 'c': + + if (arg_type != tree_constant_rep::string_constant) + goto invalid_conversion; + else + { + chars_from_fmt_str++; + fmt << *s << ends; + char *str = args[fmt_arg_count++].string_value (); + if (strlen (str) != 1) + goto invalid_conversion; + else + { + char *s = fmt.str (); + sb.form (s, *str); + delete [] s; + return chars_from_fmt_str; + } + } + + default: + goto invalid_format; + } + + invalid_conversion: + message (type, "invalid conversion"); + return -1; + + invalid_format: + message (type, "invalid format"); + return -1; +} + + +tree_constant * +do_printf (char *type, tree_constant *args, int nargin, int nargout) +{ + tree_constant *retval = NULL_TREE_CONST; + fmt_arg_count = 1; + char *fmt; + File_info file; + + if (strcmp (type, "fprintf") == 0) + { + Pix p; + + if (args[2].is_string_type ()) + { + fmt = args[2].string_value (); + fmt_arg_count++; + } + else + { + error ("%s: format must be a string", type); + return retval; + } + + if (args[1].is_scalar_type ()) + { + p = return_valid_file (args[1]); + if (p == (Pix) NULL) + return retval; + } + else if (args[1].is_string_type ()) + { + p = return_valid_file (args[1]); + if (p == (Pix) NULL) + p = fopen_file_for_user (args[1], "a+"); + } + else + { + error ("%s: illegal file specifier", type); + return retval; + } + + file = file_list (p); + if (file.mode () == "r") + { + error ("%s: file is read only", type); + return retval; + } + fmt = args[2].string_value (); + fmt_arg_count++; + } + else if (args[1].is_string_type ()) + { + fmt = args[1].string_value (); + fmt_arg_count++; + } + else + { + error ("%s: invalid format string", type); + return retval; + } + +// Scan fmt for % escapes and print out the arguments. + + ostrstream output_buf; + + char *ptr = fmt; + + for (;;) + { + char c; + while ((c = *ptr++) != '\0' && c != '%') + output_buf << c; + + if (c == '\0') + break; + + if (*ptr == '%') + { + ptr++; + output_buf << c; + continue; + } + +// We must be looking at a format specifier. Extract it or fail. + + + int status = process_printf_format (ptr, args, output_buf, type, + nargin); + + if (status < 0) + return retval; + + ptr += status; + } + + output_buf << ends; + if (strcmp (type, "printf") == 0 + || (strcmp (type, "fprintf") == 0 && file.number () == 1)) + { + maybe_page_output (output_buf); + } + else if (strcmp (type, "fprintf") == 0) + { + char *msg = output_buf.str (); + int success = fputs (msg, file.fptr ()); + if (success == EOF) + error ("%s: writing to file", type); + delete [] msg; + } + else if (strcmp (type, "sprintf") == 0) + { + retval = new tree_constant [2]; + char *msg = output_buf.str (); + retval[0] = tree_constant (msg); + delete [] msg; + } + + return retval; +} + +static int +process_scanf_format (char *s, tree_constant *args, ostrstream& fmt, + char *type, int nargout, FILE* fptr, + tree_constant *values) +{ + fmt << "%"; + + tree_constant_rep::constant_type arg_type; + + int chars_from_fmt_str = 0; + int store_value = 1; + int string_width = -1; + int success = 1; + + if (*s == '*') + { + store_value = 0; + s++; + chars_from_fmt_str++; + } + + if (isdigit (*s)) + { + ostrstream str_number; + while (*s != '\0' && isdigit (*s)) + { + chars_from_fmt_str++; + str_number << *s; + fmt << *s++; + } + str_number << ends; + char *number = str_number.str (); + string_width = atoi (number); + delete [] number; + } + + if (*s == '\0') + goto invalid_format; + + if (*s != '\0' && (*s == 'h' || *s == 'l' || *s == 'L')) + { + chars_from_fmt_str++; + s++; + } + + if (*s == '\0') + goto invalid_format; + + if (fmt_arg_count >= nargout && store_value) + { + message (type, "not enough arguments"); + return -1; + } + + arg_type = args[fmt_arg_count].const_type (); + + switch (*s) + { + case 'd': case 'i': case 'o': case 'u': case 'x': case 'X': + { + chars_from_fmt_str++; + fmt << *s << ends; + int temp; + char *str = fmt.str (); + success = fscanf (fptr, str, &temp); + delete [] str; + if (success > 0 && store_value) + values[fmt_arg_count++] = tree_constant ((double) temp); + } + break; + case 'e': case 'E': case 'f': case 'g': case 'G': + { + chars_from_fmt_str++; + fmt << 'l' << *s << ends; + double temp; + char *str = fmt.str (); + success = fscanf (fptr, str, &temp); + delete [] str; + if (success > 0 && store_value) + values[fmt_arg_count++] = tree_constant (temp); + } + break; + case 's': + { + if (string_width < 1) + { + string_width = 0; + long original_position = ftell (fptr); + int c; + + while ((c = getc (fptr)) != EOF + && (c == ' ' || c == '\n' || c != '\t')) + ; // Don't count leading whitespace. + + if (c != EOF) + string_width++; + + for (;;) + { + c = getc (fptr); + if (c != EOF && c != ' ' && c != '\n' && c != '\t') + string_width++; + else + break; + } + + fseek (fptr, original_position, SEEK_SET); + } + chars_from_fmt_str++; + char temp[string_width+1]; + fmt << *s << ends; + char *str = fmt.str (); + success = fscanf (fptr, str, temp); + delete [] str; + if (success && store_value) + values[fmt_arg_count++] = tree_constant (temp); + } + break; + case 'c': + { + if (string_width < 1) + string_width = 1; + chars_from_fmt_str++; + char temp[string_width+1]; + memset (temp, '\0', string_width+1); + fmt << *s << ends; + char *str = fmt.str (); + success = fscanf (fptr, str, temp); + delete [] str; + temp[string_width] = '\0'; + if (success > 0 && store_value) + values[fmt_arg_count++] = tree_constant (temp); + } + break; + default: + goto invalid_format; + } + + if (success > 0 || (success == 0 && store_value == 0)) + return chars_from_fmt_str; + + if (success == 0) + message (type, "invalid conversion"); + else if (success == EOF) + { + if (strcmp (type, "fscanf") == 0) + message (type, "end of file reached before final conversion"); + else if (strcmp (type, "sscanf") == 0) + message (type, "end of string reached before final conversion"); + else if (strcmp (type, "scanf") == 0) + message (type, "end of input reached before final conversion"); + } + else + { + invalid_format: + message (type, "invalid format"); + } + + return -1; +} + +tree_constant * +do_scanf (char *type, tree_constant *args, int nargin, int nargout) +{ + tree_constant *retval = NULL_TREE_CONST; + char *scanf_fmt = (char *) NULL; + char *tmp_file = (char *) NULL; + int tmp_file_open = 0; + FILE *fptr = (FILE *) NULL; + File_info file; + + fmt_arg_count = 0; + + if (strcmp (type, "scanf") != 0) + { + if ( args[2].is_string_type ()) + scanf_fmt = args[2].string_value (); + else + { + error ("%s: format must be a string", type); + return retval; + } + } + + int doing_fscanf = (strcmp (type, "fscanf") == 0); + + if (doing_fscanf) + { + Pix p; + if (args[1].is_scalar_type () + || args[1].is_string_type ()) + { + p = return_valid_file (args[1]); + if (p == (Pix) NULL) + return retval; + } + else + { + error ("%s: illegal file specifier", type); + return retval; + } + + file = file_list (p); + + if (strcmp (file.mode (), "w") == 0 || strcmp (file.mode (), "a") == 0) + { + error ("%s: this file is opened for writing only", type); + return retval; + } + + fptr = file.fptr (); + } + + if (args[1].is_string_type () || (doing_fscanf && file.number () == 0)) + { + char *string; + + if (strcmp (type, "scanf") == 0) + scanf_fmt = args[1].string_value (); + + if (strcmp (type, "scanf") == 0 + || (doing_fscanf && file.number () == 0)) + { + string = gnu_readline (""); + if (string && *string) + maybe_save_history (string); + } + else + string = args[1].string_value (); + + tmp_file = tmpnam ((char *) NULL); + + fptr = fopen (tmp_file, "w+"); + if (fptr == (FILE *) NULL) + { + error ("%s: error opening temporary file", type); + return retval; + } + tmp_file_open = 1; + unlink (tmp_file); + + if (string == (char *) NULL) + panic_impossible (); + + int success = fputs (string, fptr); + fflush (fptr); + rewind (fptr); + + if (success < 0) + { + error ("%s: trouble writing temporary file", type); + fclose (fptr); + return retval; + } + } + else if (! doing_fscanf) + { + error ("%s: first argument must be a string", type); + return retval; + } + +// Scan scanf_fmt for % escapes and assign the arguments. + + retval = new tree_constant[nargout+1]; + + char *ptr = scanf_fmt; + + for (;;) + { + ostrstream fmt; + char c; + while ((c = *ptr++) != '\0' && c != '%') + fmt << c; + + if (c == '\0') + break; + + if (*ptr == '%') + { + ptr++; + fmt << c; + continue; + } + +// We must be looking at a format specifier. Extract it or fail. + + int status = process_scanf_format (ptr, args, fmt, type, + nargout, fptr, retval); + + if (status < 0) + { + if (fmt_arg_count == 0) + { + delete [] retval; + retval = NULL_TREE_CONST; + } + break; + } + + ptr += status; + } + + if (tmp_file_open) + fclose (fptr); + + return retval; +} + +/* +;;; Local Variables: *** +;;; mode: C++ *** +;;; page-delimiter: "^/\\*" *** +;;; End: *** +*/
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/file-io.h Sun Aug 08 01:13:40 1993 +0000 @@ -0,0 +1,73 @@ +// file-io.h -*- C++ -*- +/* + +Copyright (C) 1993 John W. Eaton + +This file is part of Octave. + +Octave is free software; you can redistribute it and/or modify it +under the terms of the GNU General Public License as published by the +Free Software Foundation; either version 2, or (at your option) any +later version. + +Octave is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +for more details. + +You should have received a copy of the GNU General Public License +along with Octave; see the file COPYING. If not, write to the Free +Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. + +*/ + +// Written by John C. Campbell <jcc@che.utexas.edu>. + +#if !defined (_files_h) +#define _files_h 1 + +#ifdef __GNUG__ +#pragma interface +#endif + +#include "tree-const.h" +#include "utils.h" +#include <Pix.h> +#include <stdio.h> + +extern Pix return_valid_file (tree_constant& arg); + +extern tree_constant *fclose_internal (tree_constant *args); + +extern tree_constant *fflush_internal (tree_constant *args); + +extern tree_constant *fgets_internal (tree_constant *args, int nargout); + +extern tree_constant *fopen_internal (tree_constant *args); + +extern tree_constant *freport_internal (); + +extern tree_constant *frewind_internal (tree_constant *args); + +extern tree_constant *fseek_internal (tree_constant *args, int nargin); + +extern tree_constant *ftell_internal (tree_constant *args); + +extern void initialize_file_io (); + +extern void close_files (); + +extern tree_constant *do_printf (char *type, tree_constant *args, + int nargin, int nargout); + +extern tree_constant *do_scanf (char *type, tree_constant *args, + int nargin, int nargout); + +#endif + +/* +;;; Local Variables: *** +;;; mode: C++ *** +;;; page-delimiter: "^/\\*" *** +;;; End: *** +*/
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/fsolve.cc Sun Aug 08 01:13:40 1993 +0000 @@ -0,0 +1,164 @@ +// tc-fsolve.cc -*- C++ -*- +/* + +Copyright (C) 1993 John W. Eaton + +This file is part of Octave. + +Octave is free software; you can redistribute it and/or modify it +under the terms of the GNU General Public License as published by the +Free Software Foundation; either version 2, or (at your option) any +later version. + +Octave is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +for more details. + +You should have received a copy of the GNU General Public License +along with Octave; see the file COPYING. If not, write to the Free +Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. + +*/ + +#ifdef __GNUG__ +#pragma implementation +#endif + +#include "NLEqn.h" + +#include "tree-const.h" +#include "variables.h" +#include "gripes.h" +#include "error.h" +#include "utils.h" + +// Global pointer for user defined function required by hybrd1. +static tree *fsolve_fcn; + +#ifdef WITH_DLD +tree_constant * +builtin_fsolve (tree_constant *args, int nargin, int nargout) +{ + return fsolve (args, nargin, nargout); +} +#endif + +int +hybrd_info_to_fsolve_info (int info) +{ + switch (info) + { + case 0: + info = -1; + break; + case 1: + break; + case 2: + info = 4; + break; + case 3: + case 4: + case 5: + info = 3; + break; + default: + panic_impossible (); + break; + } + return info; +} + +ColumnVector +fsolve_user_function (ColumnVector& x) +{ + ColumnVector retval; + + int n = x.capacity (); + +// tree_constant name = tree_constant (fsolve_fcn->name ()); + tree_constant *args = new tree_constant [2]; +// args[0] = name; + + if (n > 1) + { + Matrix m (n, 1); + for (int i = 0; i < n; i++) + m (i, 0) = x.elem (i); + tree_constant vars (m); + args[1] = vars; + } + else + { + double d = x.elem (0); + tree_constant vars (d); + args[1] = vars; + } + + if (fsolve_fcn != NULL_TREE) + { + tree_constant *tmp = fsolve_fcn->eval (args, 2, 1, 0); + delete [] args; + if (tmp != NULL_TREE_CONST && tmp[0].is_defined ()) + { + retval = tmp[0].to_vector (); + delete [] tmp; + } + else + { + delete [] tmp; + gripe_user_supplied_eval ("fsolve"); + jump_to_top_level (); + } + } + + return retval; +} + +tree_constant * +fsolve (tree_constant *args, int nargin, int nargout) +{ +// Assumes that we have been given the correct number of arguments. + + tree_constant *retval = NULL_TREE_CONST; + + fsolve_fcn = is_valid_function (args[1], "fsolve", 1); + if (fsolve_fcn == NULL_TREE + || takes_correct_nargs (fsolve_fcn, 2, "fsolve", 1) != 1) + return retval; + + ColumnVector x = args[2].to_vector (); + + if (nargin > 3) + message ("fsolve", "ignoring optional arguments..."); + + if (nargout > 2) + message ("fsolve", "can't compute path output yet..."); + + NLFunc foo_fcn (fsolve_user_function); + NLEqn foo (x, foo_fcn); + + int info; + ColumnVector soln = foo.solve (info); + + info = hybrd_info_to_fsolve_info (info); + + retval = new tree_constant [nargout+1]; + retval[0] = tree_constant (soln, 1); + + if (nargout > 1) + retval[1] = tree_constant ((double) info); + + if (nargout > 2) + retval[2] = tree_constant (); + + return retval; +} + +/* +;;; Local Variables: *** +;;; mode: C++ *** +;;; page-delimiter: "^/\\*" *** +;;; End: *** +*/ +
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/fsqp.cc Sun Aug 08 01:13:40 1993 +0000 @@ -0,0 +1,92 @@ +// tc-fsqp.cc -*- C++ -*- +/* + +Copyright (C) 1993 John W. Eaton + +This file is part of Octave. + +Octave is free software; you can redistribute it and/or modify it +under the terms of the GNU General Public License as published by the +Free Software Foundation; either version 2, or (at your option) any +later version. + +Octave is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +for more details. + +You should have received a copy of the GNU General Public License +along with Octave; see the file COPYING. If not, write to the Free +Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. + +*/ + +#ifdef __GNUG__ +#pragma implementation +#endif + +#ifndef FSQP_MISSING + +#include "FSQP.h" + +#include "tree-const.h" +#include "error.h" + +// Global pointers for user defined functions required by fsqp. +static tree *fsqp_objective; +static tree *fsqp_constraints; + +#ifdef WITH_DLD +tree_constant * +builtin_fsqp_2 (tree_constant *args, int nargin, int nargout) +{ + return fsqp (args, nargin, nargout); +} +#endif + +double +fsqp_objective_function (ColumnVector& x) +{ + return 0.0; +} + +ColumnVector +fsqp_constraint_function (ColumnVector& x) +{ + ColumnVector retval; + return retval; +} + +tree_constant * +fsqp (tree_constant *args, int nargin, int nargout) +{ +/* + +Handle all of the following: + + 1. fsqp (x, phi) + 2. fsqp (x, phi, lb, ub) + 3. fsqp (x, phi, lb, ub, llb, c, lub) + 4. fsqp (x, phi, lb, ub, llb, c, lub, nllb, g, nlub) + 5. fsqp (x, phi, lb, ub, nllb, g, nlub) + 6. fsqp (x, phi, llb, c, lub, nllb, g, nlub) + 7. fsqp (x, phi, llb, c, lub) + 8. fsqp (x, phi, nllb, g, nlub) + +*/ + +// Assumes that we have been given the correct number of arguments. + + tree_constant *retval = NULL_TREE_CONST; + message ("fsqp", "not implemented yet..."); + return retval; +} + +#endif + +/* +;;; Local Variables: *** +;;; mode: C++ *** +;;; page-delimiter: "^/\\*" *** +;;; End: *** +*/
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/g-builtins.cc Sun Aug 08 01:13:40 1993 +0000 @@ -0,0 +1,1633 @@ +// g-builtins.cc -*- C++ -*- +/* + +Copyright (C) 1992, 1993 John W. Eaton + +This file is part of Octave. + +Octave is free software; you can redistribute it and/or modify it +under the terms of the GNU General Public License as published by the +Free Software Foundation; either version 2, or (at your option) any +later version. + +Octave is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +for more details. + +You should have received a copy of the GNU General Public License +along with Octave; see the file COPYING. If not, write to the Free +Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. + +*/ + +/* + +The function builtin_pwd adapted from a similar function from GNU +Bash, the Bourne Again SHell, copyright (C) 1987, 1989, 1991 Free +Software Foundation, Inc. + +*/ + +#ifdef __GNUG__ +#pragma implementation +#endif + +#include <sys/types.h> +#ifdef HAVE_UNISTD_H +#include <unistd.h> +#endif +#include <strstream.h> +#include <iostream.h> +#include <fstream.h> +#include <stdio.h> +#include <sys/wait.h> +#include <sys/param.h> +#include <signal.h> +#include <math.h> + +#include "procstream.h" +#include "error.h" +#include "variables.h" +#include "builtins.h" +#include "g-builtins.h" +#include "user-prefs.h" +#include "utils.h" +#include "tree.h" +#include "input.h" +#include "pager.h" +#include "octave.h" +#include "version.h" +#include "file-io.h" + +extern "C" +{ +#include <readline/readline.h> +} + +#ifndef MAXPATHLEN +#define MAXPATHLEN 1024 +#endif + +#ifdef WITH_DLD +#include "dynamic-ld.h" +#define Q_STR(name) #name +#define DLD_FCN(name) Q_STR (builtin_##name##_2) +#define DLD_OBJ(name) Q_STR (tc-##name##.o) +#define DLD_BUILTIN(args,n_in,n_out,name,code) \ +return octave_dld_tc2_and_go (args, n_in, n_out, Q_STR (name), \ + DLD_FCN (name), DLD_OBJ (name)); + +#else +#define DLD_BUILTIN(name,args,n_in,n_out,code) code +#endif + +// Non-zero means that pwd always give verbatim directory, regardless +// of symbolic link following. +static int verbatim_pwd = 1; + +// Signal handler return type. +#ifndef RETSIGTYPE +#define RETSIGTYPE void +#endif +#ifndef BADSIG +#define BADSIG (RETSIGTYPE (*)())-1 +#endif + +typedef RETSIGTYPE sig_handler (...); + +/* + * Are all elements of a constant nonzero? + */ +tree_constant * +builtin_all (tree_constant *args, int nargin, int nargout) +{ + tree_constant *retval = NULL_TREE_CONST; + if (nargin != 2) + usage ("all (M)"); + else + { + if (args != NULL_TREE_CONST && args[1].is_defined ()) + { + retval = new tree_constant [2]; + retval[0] = args[1].all (); + } + } + return retval; +} + +/* + * Are any elements of a constant nonzero? + */ +tree_constant * +builtin_any (tree_constant *args, int nargin, int nargout) +{ + tree_constant *retval = NULL_TREE_CONST; + if (nargin != 2) + usage ("any (M)"); + else + { + if (args != NULL_TREE_CONST && args[1].is_defined ()) + { + retval = new tree_constant [2]; + retval[0] = args[1].any (); + } + } + return retval; +} + +/* + * Clear the screen? + */ +tree_constant * +builtin_clc (tree_constant *args, int nargin, int nargout) +{ + rl_beg_of_line (); + rl_kill_line (1); + rl_clear_screen (); + return NULL_TREE_CONST; +} + +/* + * Time in a vector. + */ +tree_constant * +builtin_clock (tree_constant *args, int nargin, int nargout) +{ + tree_constant *retval = NULL_TREE_CONST; + + time_t now; + struct tm *tm; + + time (&now); + tm = localtime (&now); + + Matrix m (1, 6); + m.elem (0, 0) = tm->tm_year + 1900; + m.elem (0, 1) = tm->tm_mon + 1; + m.elem (0, 2) = tm->tm_mday; + m.elem (0, 3) = tm->tm_hour; + m.elem (0, 4) = tm->tm_min; + m.elem (0, 5) = tm->tm_sec; + + retval = new tree_constant [2]; + retval[0] = tree_constant (m); + + return retval; +} + +/* + * Close the stream to the plotter. + */ +tree_constant * +builtin_closeplot (tree_constant *args, int nargin, int nargout) +{ + tree_constant *retval = NULL_TREE_CONST; + close_plot_stream (); + return retval; +} + +/* + * Collocation roots and weights. + */ +tree_constant * +builtin_colloc (tree_constant *args, int nargin, int nargout) +{ + tree_constant *retval = NULL_TREE_CONST; + + if (nargin < 2 || nargin > 4) + usage ("[r, A, B, q] = colloc (n [, \"left\"] [, \"right\"])"); + else + DLD_BUILTIN (args, nargin, nargout, colloc, + retval = collocation_weights (args, nargin);) + + return retval; +} + +/* + * Cumulative sums and products. + */ +tree_constant * +builtin_cumprod (tree_constant *args, int nargin, int nargout) +{ + tree_constant *retval = NULL_TREE_CONST; + if (nargin != 2) + usage ("cumprod (M)"); + else + { + if (args != NULL_TREE_CONST && args[1].is_defined ()) + { + retval = new tree_constant [2]; + retval[0] = args[1].cumprod (); + } + } + return retval; +} + +tree_constant * +builtin_cumsum (tree_constant *args, int nargin, int nargout) +{ + tree_constant *retval = NULL_TREE_CONST; + if (nargin != 2) + usage ("cumsum (M)"); + else + { + if (args != NULL_TREE_CONST && args[1].is_defined ()) + { + retval = new tree_constant [2]; + retval[0] = args[1].cumsum (); + } + } + return retval; +} + +/* + * DAEs. + */ +static void +dassl_usage (void) +{ + usage ("dassl (\"function_name\", x_0, xdot_0, t_out\n\ + dassl (\"function_name\", x_0, xdot_0, t_out, t_crit)\n\ +\n\ + The first argument is the name of the function to call to\n\ + compute the vector of residuals. It must have the form\n\ +\n\ + res = f (x, xdot, t)\n\ +\n\ + where x, xdot, and res are vectors, and t is a scalar."); +} + +tree_constant * +builtin_dassl (tree_constant *args, int nargin, int nargout) +{ + tree_constant *retval = new tree_constant [2]; + + if ((nargin == 5 || nargin == 6) && nargout > 0) + DLD_BUILTIN (args, nargin, nargout, dassl, + retval = dassl (args, nargin, nargout);) + else + dassl_usage (); + + return retval; +} + +/* + * Time in a string. + */ +tree_constant * +builtin_date (tree_constant *args, int nargin, int nargout) +{ + tree_constant *retval = NULL_TREE_CONST; + + time_t now; + struct tm *tm; + + time (&now); + tm = localtime (&now); + char date[32]; + int len = strftime (date, 31, "%d-%b-%y", tm); + if (len > 0) + { + retval = new tree_constant [2]; + retval[0] = tree_constant (date); + } + + return retval; +} + +/* + * Determinant of a matrix. + */ +tree_constant * +builtin_det (tree_constant *args, int nargin, int nargout) +{ + tree_constant *retval = NULL_TREE_CONST; + + if (nargin == 2) + DLD_BUILTIN (args, nargin, nargout, det, + { + retval = new tree_constant [2]; + retval[0] = determinant (args[1]); + }) + else + usage ("det (a)"); + + return retval; +} + +/* + * Diagonal elements of a matrix. + */ +tree_constant * +builtin_diag (tree_constant *args, int nargin, int nargout) +{ + tree_constant *retval = NULL_TREE_CONST; + + if (nargin == 2) + { + retval = new tree_constant [2]; + retval[0] = args[1].diag (); + } + else if (nargin == 3) + { + retval = new tree_constant [2]; + retval[0] = args[1].diag (args[2]); + } + else + usage ("diag (X [, k])"); + + return retval; +} + +/* + * Display value without trimmings. + */ +tree_constant * +builtin_disp (tree_constant *args, int nargin, int nargout) +{ + tree_constant *retval = NULL_TREE_CONST; + + if (nargin == 2) + args[1].eval (1); + else + usage ("disp (X)"); + + return retval; +} + +/* + * Compute eigenvalues and eigenvectors. + */ +tree_constant * +builtin_eig (tree_constant *args, int nargin, int nargout) +{ + tree_constant *retval = NULL_TREE_CONST; + + if (nargin == 2 && (nargout == 1 || nargout == 2)) + DLD_BUILTIN (args, nargin, nargout, eig, + retval = eig (args, nargin, nargout);) + else + usage ("lambda = eig (A)\n\ + [v, d] = eig (A); d == diag (lambda)"); + + return retval; +} + +/* + * Print error message and jump to top level. + */ +tree_constant * +builtin_error (tree_constant *args, int nargin, int nargout) +{ + tree_constant *retval = NULL_TREE_CONST; + + if (nargin == 2 && args != NULL_TREE_CONST && args[1].is_defined ()) + args[1].print_if_string (cerr, 1); + else + message ((char *) NULL, "unspecified error, jumping to top level..."); + + jump_to_top_level (); + + return retval; +} + +/* + * Evaluate text argument as octave source. + */ +tree_constant * +builtin_eval (tree_constant *args, int nargin, int nargout) +{ + tree_constant *retval = NULL_TREE_CONST; + if (nargin == 2) + { + int parse_status = 0; + retval = new tree_constant [2]; + retval[0] = eval_string (args[1], parse_status); + } + else + usage ("eval (\"string\")"); + return retval; +} + +/* + * Check if variable or file exists. + */ +tree_constant * +builtin_exist (tree_constant *args, int nargin, int nargout) +{ + tree_constant *retval = NULL_TREE_CONST; + if (nargin == 2 && args[1].is_string_type ()) + { + int status = identifier_exists (args[1].string_value ()); + retval = new tree_constant [2]; + retval[0] = tree_constant ((double) status); + } + else + usage ("exist (\"string\")"); + return retval; +} + +/* + * Matrix exponential. + */ +tree_constant * +builtin_expm (tree_constant *args, int nargin, int nargout) +{ + tree_constant *retval = NULL_TREE_CONST; + + if (nargin == 2) + retval = matrix_exp (args[1]); + else + usage ("expm (A)"); + + return retval; +} + +/* + * Identity matrix. + */ +tree_constant * +builtin_eye (tree_constant *args, int nargin, int nargout) +{ + tree_constant *retval = NULL_TREE_CONST; + + switch (nargin) + { + case 2: + retval = new tree_constant [2]; + retval[0] = identity_matrix (args[1]); + break; + case 3: + retval = new tree_constant [2]; + retval[0] = identity_matrix (args[1], args[2]); + break; + default: + usage ("eye (n)\n eye (A)\n eye (n, m)"); + break; + } + return retval; +} + + +/* + * Closing a file + */ +tree_constant * +builtin_fclose (tree_constant *args, int nargin, int nargout) +{ + tree_constant *retval = NULL_TREE_CONST; + if (nargin != 2) + usage ("success = fclose (\"filename\" or filenum)"); + else + retval = fclose_internal (args); + return retval; +} + +/* + * Evaluate first argument as a function. + */ +tree_constant * +builtin_feval (tree_constant *args, int nargin, int nargout) +{ + tree_constant *retval = NULL_TREE_CONST; + if (nargin > 1) + retval = feval (args, nargin, nargout); + else + usage ("feval (\"function_name\" [, ...])"); + return retval; +} + +/* + * Flushing output to a file + */ +tree_constant * +builtin_fflush (tree_constant *args, int nargin, int nargout) +{ + tree_constant *retval = NULL_TREE_CONST; + if (nargin != 2) + usage ("success = fflush (\"filename\" or filenum)"); + else + retval = fflush_internal (args); + return retval; +} + +/* + * Fast Fourier Transform + */ +tree_constant * +builtin_fft (tree_constant *args, int nargin, int nargout) +{ + tree_constant *retval = NULL_TREE_CONST; + + if (nargin == 2) + DLD_BUILTIN (args, nargin, nargout, fft, + { + retval = new tree_constant [2]; + retval[0] = fft (args[1]); + }) + else + usage ("fft (a)"); + + return retval; +} + +/* + * get a string from a file + */ +tree_constant * +builtin_fgets (tree_constant *args, int nargin, int nargout) +{ + tree_constant *retval = NULL_TREE_CONST; + if (nargin != 3 && nargout < 3) + usage ("string = fgets (\"filename\" or filenum, length)"); + else + retval = fgets_internal (args, nargout); + return retval; +} + +/* + * Find nonzero elements. This should probably only work if + * do_fortran_indexing is true... + */ +tree_constant * +builtin_find (tree_constant *args, int nargin, int nargout) +{ + tree_constant *retval = NULL_TREE_CONST; + if (nargin == 2) + { + retval = new tree_constant [2]; + retval[0] = find_nonzero_elem_idx (args[1]); + } + else + usage ("find (x)"); + return retval; +} + +/* + * Don\'t really count floating point operations. + */ +tree_constant * +builtin_flops (tree_constant *args, int nargin, int nargout) +{ + tree_constant *retval = NULL_TREE_CONST; + if (nargin > 2) + usage ("flops\n flops (0)"); + + warning ("flops always returns zero"); + retval = new tree_constant [2]; + retval[0] = tree_constant (0.0); + return retval; +} + +/* + * Opening a file. + */ +tree_constant * +builtin_fopen (tree_constant *args, int nargin, int nargout) +{ + tree_constant *retval = NULL_TREE_CONST; + if (nargin != 3) + { + usage ("filenum = fopen (\"file\", \"mode\")\n\n\ + Legal values for mode include:\n\n\ + r : open text file for reading\n\ + w : open text file for writing; discard previous contents if any\n\ + a : append; open or create text file for writing at end of file\n\ + r+ : open text file for update (i.e., reading and writing)\n\ + w+ : create text file for update; discard previous contents if any\n\ + a+ : append; open or create text file for update, writing at end\n\n\ + Update mode permits reading from and writing to the same file.\n"); + } + else + retval = fopen_internal (args); + return retval; +} + +/* + * Formatted printing to a file. + */ +tree_constant * +builtin_fprintf (tree_constant *args, int nargin, int nargout) +{ + tree_constant *retval = NULL_TREE_CONST; + if (nargin < 3) + usage ("fprintf (\"filename\" or filenum, \"fmt\" [, ...])"); + else + retval = do_printf ("fprintf", args, nargin, nargout); + return retval; +} + +/* + * rewind a file + */ +tree_constant * +builtin_frewind (tree_constant *args, int nargin, int nargout) +{ + tree_constant *retval = NULL_TREE_CONST; + if (nargin != 2) + usage ("success = frewind (\"filename\" or filenum)"); + else + retval = frewind_internal (args); + return retval; +} + +/* + * report on open files + */ +tree_constant * +builtin_freport (tree_constant *args, int nargin, int nargout) +{ + tree_constant *retval = NULL_TREE_CONST; + if (nargin > 1) + warning ("replot: ignoring extra arguments"); + retval = freport_internal (); + return retval; +} + +/* + * Formatted reading from a file. + */ +tree_constant * +builtin_fscanf (tree_constant *args, int nargin, int nargout) +{ + tree_constant *retval = NULL_TREE_CONST; + if (nargin != 2 && nargin != 3) + usage ("[...] = fscanf (\"file\", \"fmt\")"); + else + retval = do_scanf ("fscanf", args, nargin, nargout); + return retval; +} + +/* + * seek a point in a file for reading and/or writing + */ +tree_constant * +builtin_fseek (tree_constant *args, int nargin, int nargout) +{ + tree_constant *retval = NULL_TREE_CONST; + if (nargin != 3 && nargin != 4) + usage ("success = fseek (\"filename\" or filenum, offset [,origin])"); + else + retval = fseek_internal (args, nargin); + return retval; +} + +/* + * Nonlinear algebraic equations. + */ +static void +fsolve_usage (void) +{ +// usage ("[x, status, path] = fsolve (\"f\", x0 [, opts] [, par] [, \"jac\"] [, scale])"); + + usage ("[x, info] = fsolve (\"f\", x0)"); +} + +tree_constant * +builtin_fsolve (tree_constant *args, int nargin, int nargout) +{ + tree_constant *retval = NULL_TREE_CONST; + + if (nargin >= 3 && nargin <= 7 && nargout >= 1 && nargout <= 3) + DLD_BUILTIN (args, nargin, nargout, fsolve, + retval = fsolve (args, nargin, nargout);) + else + fsolve_usage (); + + return retval; +} + +/* + * NLPs. + */ +static void +fsqp_usage (void) +{ +#if defined (FSQP_MISSING) + message ("fsqp", "this function requires FSQP, which is not freely\n\ + redistributable. For more information, read the file\n\ + libcruft/fsqp/README.MISSING in the source distribution."); +#else + usage ("[x, phi] = fsqp (x, \"phi\" [, lb, ub] [, lb, A, ub] [, lb, \"g\", ub])\n\n\ + Groups of arguments surrounded in `[]' are optional, but\n\ + must appear in the same relative order shown above."); +#endif +} + +tree_constant * +builtin_fsqp (tree_constant *args, int nargin, int nargout) +{ + tree_constant *retval = NULL_TREE_CONST; + +#if defined (FSQP_MISSING) + fsqp_usage (); +#else + if ((nargin == 3 || nargin == 5 || nargin == 6 || nargin == 8 + || nargin == 9 || nargin == 11) + && (nargout >= 1 && nargout <= 3)) + DLD_BUILTIN (args, nargin, nargout, fsqp, + retval = fsqp (args, nargin, nargout);) + else + fsqp_usage (); +#endif + + return retval; +} + +/* + * tell current position of file + */ +tree_constant * +builtin_ftell (tree_constant *args, int nargin, int nargout) +{ + tree_constant *retval = NULL_TREE_CONST; + if (nargin != 2) + usage ("position = ftell (\"filename\" or filenumber)"); + else + retval = ftell_internal (args); + return retval; +} + +/* + * Get the value of an environment variable. + */ +tree_constant * +builtin_getenv (tree_constant *args, int nargin, int nargout) +{ + tree_constant *retval = NULL_TREE_CONST; + if (nargin == 2 && args[1].is_string_type ()) + { + retval = new tree_constant [2]; + char *value = getenv (args[1].string_value ()); + if (value != (char *) NULL) + retval[0] = tree_constant (value); + else + retval[0] = tree_constant (""); + } + else + usage ("getenv (\"string\")"); + return retval; +} + +/* + * Inverse Fast Fourier Transform + */ +tree_constant * +builtin_ifft (tree_constant *args, int nargin, int nargout) +{ + tree_constant *retval = NULL_TREE_CONST; + + if (nargin == 2) + DLD_BUILTIN (args, nargin, nargout, ifft, + { + retval = new tree_constant [2]; + retval[0] = ifft (args[1]); + }) + else + usage ("ifft (a)"); + + return retval; +} + +/* + * Inverse of a square matrix. + */ +tree_constant * +builtin_inv (tree_constant *args, int nargin, int nargout) +{ + tree_constant *retval = NULL_TREE_CONST; + + if (nargin == 2) + DLD_BUILTIN (args, nargin, nargout, inv, + { + retval = new tree_constant [2]; + retval[0] = inverse (args[1]); + }) + else + usage ("inv (A)"); + + return retval; +} + +/* + * Prompt user for input. + */ +tree_constant * +builtin_input (tree_constant *args, int nargin, int nargout) +{ + tree_constant *retval = NULL_TREE_CONST; + + if (nargin == 2 || nargin == 3) + { + retval = new tree_constant [2]; + retval[0] = get_user_input (args, nargin, nargout); + } + else + usage ("input (\"prompt\" [, \"s\"])"); + + return retval; +} + +/* + * Is the argument a string? + */ +tree_constant * +builtin_isstr (tree_constant *args, int nargin, int nargout) +{ + tree_constant *retval = NULL_TREE_CONST; + if (nargin != 2) + usage ("isstr (value)"); + else + { + if (args != NULL_TREE_CONST && args[1].is_defined ()) + { + retval = new tree_constant [2]; + retval[0] = args[1].isstr (); + } + } + return retval; +} + +/* + * Maybe help in debugging. + */ +tree_constant * +builtin_keyboard (tree_constant *args, int nargin, int nargout) +{ + tree_constant *retval = NULL_TREE_CONST; + + if (nargin == 1 || nargin == 2) + { + retval = new tree_constant [2]; + retval[0] = get_user_input (args, nargin, nargout, 1); + } + else + usage ("keyboard (\"prompt\")"); + + return retval; +} + +/* + * Matrix logarithm. + */ +tree_constant * +builtin_logm (tree_constant *args, int nargin, int nargout) +{ + tree_constant *retval = NULL_TREE_CONST; + + if (nargin == 2) + retval = matrix_log (args[1]); + else + usage ("logm (A)"); + + return retval; +} + +/* + * LPs. + */ +static void +lpsolve_usage (void) +{ + usage ("[x, obj, info] = lpsolve (XXX FIXME XXX)"); +} + +tree_constant * +builtin_lpsolve (tree_constant *args, int nargin, int nargout) +{ + tree_constant *retval = NULL_TREE_CONST; + +// Force a bad value of inform, and empty matrices for x and phi. + retval = new tree_constant [4]; + Matrix m; + retval[0] = tree_constant (m); + retval[1] = tree_constant (m); + retval[2] = tree_constant (-1.0); + + if (nargin == 0) + DLD_BUILTIN (args, nargin, nargout, lpsolve, + retval = lpsolve (args, nargin, nargout);) + else + lpsolve_usage (); + + return retval; +} + +/* + * ODEs. + */ +static void +lsode_usage (void) +{ + usage ("lsode (\"function_name\", x0, t_out\n\ + lsode (\"function_name\", x0, t_out, t_crit)\n\ +\n\ + The first argument is the name of the function to call to\n\ + compute the vector of right hand sides. It must have the form\n\ +\n\ + xdot = f (x, t)\n\ +\n\ + where xdot and x are vectors and t is a scalar."); +} + +tree_constant * +builtin_lsode (tree_constant *args, int nargin, int nargout) +{ + tree_constant *retval = NULL_TREE_CONST; + + if ((nargin == 4 || nargin == 5) && nargout == 1) + DLD_BUILTIN (args, nargin, nargout, lsode, + retval = lsode (args, nargin, nargout);) + else + lsode_usage (); + + return retval; +} + +/* + * LU factorization. + */ +tree_constant * +builtin_lu (tree_constant *args, int nargin, int nargout) +{ + tree_constant *retval = NULL_TREE_CONST; + + if (nargin == 2 && nargout < 4) + DLD_BUILTIN (args, nargin, nargout, lu, + retval = lu (args[1], nargout);) + else + usage ("[L, U, P] = lu (A)"); + + return retval; +} + +/* + * Max values. + */ +tree_constant * +builtin_max (tree_constant *args, int nargin, int nargout) +{ + tree_constant *retval = NULL_TREE_CONST; + + if ((nargin == 2 && (nargout == 1 || nargout == 2)) + || (nargin == 3 && nargout == 1)) + retval = column_max (args, nargin, nargout); + else + usage ("[X, I] = max (A)\n X = max (A)\n X = max (A, B)"); + + return retval; +} + +/* + * Min values. + */ +tree_constant * +builtin_min (tree_constant *args, int nargin, int nargout) +{ + tree_constant *retval = NULL_TREE_CONST; + + if ((nargin == 2 && (nargout == 1 || nargout == 2)) + || (nargin == 3 && nargout == 1)) + retval = column_min (args, nargin, nargout); + else + usage ("[X, I] = min (A)\n X = min (A)\n X = min (A, B)"); + + return retval; +} + +/* + * NLPs. + */ +static void +npsol_usage (void) +{ +#if defined (NPSOL_MISSING) + message ("npsol", "this function requires NPSOL, which is not freely\n\ + redistributable. For more information, read the file\n\ + libcruft/npsol/README.MISSING in the source distribution."); +#else + usage ("\n\n\ + [x, obj, info, lambda] = npsol (x, \"phi\" [, lb, ub] [, lb, A, ub] [, lb, \"g\", ub])\n\n\ + Groups of arguments surrounded in `[]' are optional, but\n\ + must appear in the same relative order shown above.\n\ +\n\ + The second argument is a string containing the name of the objective\n\ + function to call. The objective function must be of the form\n\ +\n\ + y = phi (x)\n\ +\n\ + where x is a vector and y is a scalar."); +#endif +} + +tree_constant * +builtin_npsol (tree_constant *args, int nargin, int nargout) +{ + tree_constant *retval = NULL_TREE_CONST; + +#if defined (NPSOL_MISSING) +// Force a bad value of inform, and empty matrices for x, phi, and lambda. + retval = new tree_constant [4]; + Matrix m; + retval[0] = tree_constant (m); + retval[1] = tree_constant (m); + retval[2] = tree_constant (-1.0); + retval[3] = tree_constant (m); + npsol_usage (); +#else + if ((nargin == 3 || nargin == 5 || nargin == 6 || nargin == 8 + || nargin == 9 || nargin == 11) + && (nargout >= 1 && nargout <= 4)) + DLD_BUILTIN (args, nargin, nargout, npsol, + retval = npsol (args, nargin, nargout);) + else + npsol_usage (); +#endif + + return retval; +} + +/* + * A matrix of ones. + */ +tree_constant * +builtin_ones (tree_constant *args, int nargin, int nargout) +{ + tree_constant *retval = NULL_TREE_CONST; + + switch (nargin) + { + case 2: + retval = new tree_constant [2]; + retval[0] = fill_matrix (args[1], 1.0, "ones"); + break; + case 3: + retval = new tree_constant [2]; + retval[0] = fill_matrix (args[1], args[2], 1.0, "ones"); + break; + default: + usage ("ones (n)\n ones (A)\n ones (n, m)"); + break; + } + return retval; +} + +/* + * You guessed it. + */ +tree_constant * +builtin_pause (tree_constant *args, int nargin, int nargout) +{ + if (! (nargin == 1 || nargin == 2)) + { + usage ("pause ([delay])"); + return NULL_TREE_CONST; + } + + if (interactive) + { + if (nargin == 2) + sleep (NINT (args[1].double_value ())); + else if (kbhit () == EOF) + clean_up_and_exit (0); + } + return NULL_TREE_CONST; +} + +/* + * Delete turds from /tmp. + */ +tree_constant * +builtin_purge_tmp_files (tree_constant *, int, int) +{ + cleanup_tmp_files (); + return NULL_TREE_CONST; +} + +/* + * Formatted printing. + */ +tree_constant * +builtin_printf (tree_constant *args, int nargin, int nargout) +{ + tree_constant *retval = NULL_TREE_CONST; + if (nargin < 2) + usage ("printf (\"fmt\" [, ...])"); + else + retval = do_printf ("printf", args, nargin, nargout); + return retval; +} + +/* + * Product. + */ +tree_constant * +builtin_prod (tree_constant *args, int nargin, int nargout) +{ + tree_constant *retval = NULL_TREE_CONST; + if (nargin != 2) + usage ("prod (M)"); + else + { + if (args != NULL_TREE_CONST && args[1].is_defined ()) + { + retval = new tree_constant [2]; + retval[0] = args[1].prod (); + } + } + return retval; +} + +/* + * Print name of current working directory. + */ +tree_constant * +builtin_pwd (tree_constant *args, int nargin, int nargout) +{ + tree_constant *retval = NULL_TREE_CONST; + char *directory; + + if (verbatim_pwd) + { + char *buffer = new char [MAXPATHLEN]; + directory = getcwd (buffer, MAXPATHLEN); + + if (!directory) + { + message ("pwd", "can't find working directory!"); + delete buffer; + } + } + else + { + directory = get_working_directory ("pwd"); + } + + if (directory) + { + char *s = strconcat (directory, "\n"); + retval = new tree_constant [2]; + retval[0] = tree_constant (s); + delete [] s; + } + return retval; +} + +/* + * QPs. + */ +static void +qpsol_usage (void) +{ +#if defined (QPSOL_MISSING) + message ("qpsol", "this function requires QPSOL, which is not freely\n\ + redistributable. For more information, read the file\n\ + libcruft/qpsol/README.MISSING in the source distribution."); +#else + usage ("[x, obj, info, lambda] = qpsol (x, H, c [, lb, ub] [, lb, A, ub])\n\ +\n\ + Groups of arguments surrounded in `[]' are optional, but\n\ + must appear in the same relative order shown above."); +#endif +} + +tree_constant * +builtin_qpsol (tree_constant *args, int nargin, int nargout) +{ + tree_constant *retval = NULL_TREE_CONST; + +#if defined (QPSOL_MISSING) +// Force a bad value of inform, and empty matrices for x, phi, and lambda. + retval = new tree_constant [5]; + Matrix m; + retval[0] = tree_constant (m); + retval[1] = tree_constant (m); + retval[2] = tree_constant (-1.0); + retval[3] = tree_constant (m); + qpsol_usage (); +#else + if ((nargin == 4 || nargin == 6 || nargin == 7 || nargin == 9) + && (nargout >= 1 && nargout <= 4)) + DLD_BUILTIN (args, nargin, nargout, qpsol, + retval = qpsol (args, nargin, nargout);) + else + qpsol_usage (); +#endif + + return retval; +} + +/* + * QR factorization. + */ +tree_constant * +builtin_qr (tree_constant *args, int nargin, int nargout) +{ + tree_constant *retval = NULL_TREE_CONST; + + if (nargin == 2 && nargout < 3) + DLD_BUILTIN (args, nargin, nargout, qr, + retval = qr (args[1], nargout);) + else + usage ("[Q, R] = qr (A)"); + + return retval; +} + +/* + * Random numbers. + */ +tree_constant * +builtin_quad (tree_constant *args, int nargin, int nargout) +{ + tree_constant *retval = NULL_TREE_CONST; + + if ((nargin > 3 && nargin < 7) && (nargout > 0 && nargout < 5)) + DLD_BUILTIN (args, nargin, nargout, quad, + retval = do_quad (args, nargin, nargout);) + else + usage ("[v, ier, nfun, err] = quad (\"f\", a, b)\n\ + = quad (\"f\", a, b, tol)\n\ + = quad (\"f\", a, b, tol, sing)"); + + return retval; +} + +/* + * I'm outta here. + */ +tree_constant * +builtin_quit (tree_constant *args, int nargin, int nargout) +{ + quitting_gracefully = 1; + clean_up_and_exit (0); + return NULL_TREE_CONST; +} + +/* + * Random numbers. + */ +tree_constant * +builtin_rand (tree_constant *args, int nargin, int nargout) +{ + tree_constant *retval = NULL_TREE_CONST; + + if ((nargin > 0 && nargin < 4) && nargout == 1) + DLD_BUILTIN (args, nargin, nargout, rand, + retval = rand_internal (args, nargin, nargout);) + else + usage ("rand -- generate a random value\n\ + rand (n) -- generate N x N matrix\n\ + rand (A) -- generate matrix the size of A\n\ + rand (n, m) -- generate N x M matrix\n\ + rand (\"dist\") -- get current distribution\n\ + rand (\"distribution\") -- set distribution\n\ + rand (\"seed\") -- get current seed\n\ + rand (\"seed\", n) -- set seed"); + + return retval; +} + +/* + * Replot current plot. + */ +tree_constant * +builtin_replot (tree_constant *args, int nargin, int nargout) +{ + tree_constant *retval = NULL_TREE_CONST; + + if (nargin > 1) + warning ("replot: ignoring extra arguments"); + + send_to_plot_stream ("replot\n"); + + return retval; +} + +/* + * Formatted reading. + */ +tree_constant * +builtin_scanf (tree_constant *args, int nargin, int nargout) +{ + tree_constant *retval = NULL_TREE_CONST; + if (nargin != 2) + usage ("[...] = scanf (\"fmt\")"); + else + retval = do_scanf ("scanf", args, nargin, nargout); + return retval; +} + +/* + * Convert a vector to a string. + */ +tree_constant * +builtin_setstr (tree_constant *args, int nargin, int nargout) +{ + tree_constant *retval = NULL_TREE_CONST; + + if (nargin == 2) + { + retval = new tree_constant [2]; + retval[0] = args[1].convert_to_str (); + } + else + usage ("setstr (v)"); + + return retval; +} + +/* + * Execute a shell command. + */ +tree_constant * +builtin_shell_command (tree_constant *args, int nargin, int nargout) +{ + tree_constant *retval = NULL_TREE_CONST; + + if (nargin == 2 || nargin == 3) + { + if (args[1].is_string_type ()) + { + iprocstream cmd (args[1].string_value ()); + char ch; + ostrstream output_buf; + while (cmd.get (ch)) + output_buf.put (ch); + + output_buf << ends; + if (nargin == 2) + { + maybe_page_output (output_buf); + } + else + { + retval = new tree_constant [2]; + retval[0] = tree_constant (output_buf.str ()); + } + } + else + error ("shell_cmd: first argument must be a string"); + } + else + usage ("shell_cmd (string [, return_output])"); + + return retval; +} + +/* + * Report rows and columns. + */ +tree_constant * +builtin_size (tree_constant *args, int nargin, int nargout) +{ + tree_constant *retval = NULL_TREE_CONST; + + if (nargin != 2) + usage ("size (x)"); + else + { + if (args != NULL_TREE_CONST && args[1].is_defined ()) + { + int nr = args[1].rows (); + int nc = args[1].columns (); + if (nargout == 1) + { + Matrix m (1, 2); + m.elem (0, 0) = nr; + m.elem (0, 1) = nc; + retval = new tree_constant [2]; + retval[0] = tree_constant (m); + } + else if (nargout == 2) + { + retval = new tree_constant [3]; + retval[0] = tree_constant ((double) nr); + retval[1] = tree_constant ((double) nc); + } + else + usage ("[n, m] = size (A)\n size (A)"); + } + } + return retval; +} + +/* + * Sort columns. + */ +tree_constant * +builtin_sort (tree_constant *args, int nargin, int nargout) +{ + tree_constant *retval = NULL_TREE_CONST; + + if (nargin == 2) + retval = sort (args, nargin, nargout); + else + usage ("[s, i] = sort (x)"); + + return retval; +} + +/* + * Formatted printing to a string. + */ +tree_constant * +builtin_sprintf (tree_constant *args, int nargin, int nargout) +{ + tree_constant *retval = NULL_TREE_CONST; + if (nargin < 2) + usage ("string = sprintf (\"fmt\" [, ...])"); + else + retval = do_printf ("sprintf", args, nargin, nargout); + return retval; +} + +/* + * Matrix sqrt. + */ +tree_constant * +builtin_sqrtm (tree_constant *args, int nargin, int nargout) +{ + tree_constant *retval = NULL_TREE_CONST; + + if (nargin == 2) + retval = matrix_sqrt (args[1]); + else + usage ("sqrtm (A)"); + + return retval; +} + +/* + * Formatted reading from a string. + */ +tree_constant * +builtin_sscanf (tree_constant *args, int nargin, int nargout) +{ + tree_constant *retval = NULL_TREE_CONST; + if (nargin != 3) + usage ("[...] = sscanf (string, \"fmt\")"); + else + retval = do_scanf ("sscanf", args, nargin, nargout); + return retval; +} + +/* + * Sum. + */ +tree_constant * +builtin_sum (tree_constant *args, int nargin, int nargout) +{ + tree_constant *retval = NULL_TREE_CONST; + if (nargin != 2) + usage ("sum (M)"); + else + { + if (args != NULL_TREE_CONST && args[1].is_defined ()) + { + retval = new tree_constant [2]; + retval[0] = args[1].sum (); + } + } + return retval; +} + +/* + * Sum of squares. + */ +tree_constant * +builtin_sumsq (tree_constant *args, int nargin, int nargout) +{ + tree_constant *retval = NULL_TREE_CONST; + if (nargin != 2) + usage ("sumsq (M)"); + else + { + if (args != NULL_TREE_CONST && args[1].is_defined ()) + { + retval = new tree_constant [2]; + retval[0] = args[1].sumsq (); + } + } + return retval; +} + +/* + * Singluar value decomposition. + */ +tree_constant * +builtin_svd (tree_constant *args, int nargin, int nargout) +{ + tree_constant *retval = NULL_TREE_CONST; + + if (nargin == 2 && (nargout == 1 || nargout == 3)) + DLD_BUILTIN (args, nargin, nargout, svd, + retval = svd (args, nargin, nargout);) + else + usage ("[U, S, V] = svd (A)\n S = svd (A)"); + + return retval; +} + +/* + * Schur Decomposition + */ +tree_constant * +builtin_schur (tree_constant *args, int nargin, int nargout) +{ + tree_constant *retval = NULL_TREE_CONST; + + if ((nargin == 3 || nargin == 2) && (nargout == 1 || nargout == 2)) + DLD_BUILTIN (args, nargin, nargout, hess, + retval = schur (args, nargin, nargout);) + else + usage ("[U, S] = schur (A)\n\ + S = schur (A)\n\n\ + or, for ordered Schur:\n\n\ + [U, S] = schur (A, \"A, D, or U\")\n\ + S = schur (A, \"A, D, or U\")\n\ + where:\n\n\ + A = continuous time poles\n\ + D = discrete time poles\n\ + U = unordered schur (default)"); + + return retval; +} + +/* + * Hessenburg Decomposition + */ +tree_constant * +builtin_hess (tree_constant *args, int nargin, int nargout) +{ + tree_constant *retval = NULL_TREE_CONST; + + if (nargin == 2 && (nargout == 1 || nargout == 2)) + DLD_BUILTIN (args, nargin, nargout, hess, + retval = hess (args, nargin, nargout);) + else + usage ("[P, H] = hess (A)\n H = hess (A)"); + + return retval; +} + +/* + * Copying information. + */ +tree_constant * +builtin_warranty (tree_constant *args, int nargin, int nargout) +{ + ostrstream output_buf; + output_buf << "\n Octave, version " << version_string + << ". Copyright (C) 1992, 1993, John W. Eaton\n" + << "\n\ + This program is free software; you can redistribute it and/or modify\n\ + it under the terms of the GNU General Public License as published by\n\ + the Free Software Foundation; either version 2 of the License, or\n\ + (at your option) any later version.\n\n\ + This program is distributed in the hope that it will be useful,\n\ + but WITHOUT ANY WARRANTY; without even the implied warranty of\n\ + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the\n\ + GNU General Public License for more details.\n\n\ + You should have received a copy of the GNU General Public License\n\ + along with this program. If not, write to the Free Software\n\ + Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.\n\n"; + + output_buf << ends; + maybe_page_output (output_buf); + + return NULL_TREE_CONST; +} + +/* + * A matrix of zeros. + */ +tree_constant * +builtin_zeros (tree_constant *args, int nargin, int nargout) +{ + tree_constant *retval = NULL_TREE_CONST; + + switch (nargin) + { + case 2: + retval = new tree_constant [2]; + retval[0] = fill_matrix (args[1], 0.0, "zeros"); + break; + case 3: + retval = new tree_constant [2]; + retval[0] = fill_matrix (args[1], args[2], 0.0, "zeros"); + break; + default: + usage ("zeros (n)\n zeros (A)\n zeros (n, m)"); + break; + } + return retval; +} + +/* +;;; Local Variables: *** +;;; mode: C++ *** +;;; page-delimiter: "^/\\*" *** +;;; End: *** +*/
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/g-builtins.h Sun Aug 08 01:13:40 1993 +0000 @@ -0,0 +1,125 @@ +// Builtin general function support. -*- C++ -*- +/* + +Copyright (C) 1992, 1993 John W. Eaton + +This file is part of Octave. + +Octave is free software; you can redistribute it and/or modify it +under the terms of the GNU General Public License as published by the +Free Software Foundation; either version 2, or (at your option) any +later version. + +Octave is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +for more details. + +You should have received a copy of the GNU General Public License +along with Octave; see the file COPYING. If not, write to the Free +Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. + +*/ + +#if !defined (_g_builtins_h) +#define _g_builtins_h 1 + +#ifdef __GNUG__ +#pragma interface +#endif + +#include "tree-const.h" + +struct builtin_general_functions +{ + char *name; + int nargin_max; + int nargout_max; + General_fcn general_fcn; + char *help_string; +}; + +extern tree_constant *builtin_all (tree_constant *, int, int); +extern tree_constant *builtin_any (tree_constant *, int, int); +extern tree_constant *builtin_clc (tree_constant *, int, int); +extern tree_constant *builtin_clock (tree_constant *, int, int); +extern tree_constant *builtin_closeplot (tree_constant *, int, int); +extern tree_constant *builtin_colloc (tree_constant *, int, int); +extern tree_constant *builtin_cumprod (tree_constant *, int, int); +extern tree_constant *builtin_cumsum (tree_constant *, int, int); +extern tree_constant *builtin_dassl (tree_constant *, int, int); +extern tree_constant *builtin_date (tree_constant *, int, int); +extern tree_constant *builtin_det (tree_constant *, int, int); +extern tree_constant *builtin_diag (tree_constant *, int, int); +extern tree_constant *builtin_disp (tree_constant *, int, int); +extern tree_constant *builtin_eig (tree_constant *, int, int); +extern tree_constant *builtin_error (tree_constant *, int, int); +extern tree_constant *builtin_eval (tree_constant *, int, int); +extern tree_constant *builtin_exist (tree_constant *, int, int); +extern tree_constant *builtin_expm (tree_constant *, int, int); +extern tree_constant *builtin_eye (tree_constant *, int, int); +extern tree_constant *builtin_fclose (tree_constant *, int, int); +extern tree_constant *builtin_feval (tree_constant *, int, int); +extern tree_constant *builtin_fflush (tree_constant *, int, int); +extern tree_constant *builtin_fft (tree_constant *, int, int); +extern tree_constant *builtin_fgets (tree_constant *, int, int); +extern tree_constant *builtin_find (tree_constant *, int, int); +extern tree_constant *builtin_flops (tree_constant *, int, int); +extern tree_constant *builtin_fopen (tree_constant *, int, int); +extern tree_constant *builtin_fprintf (tree_constant *, int, int); +extern tree_constant *builtin_frewind (tree_constant *, int, int); +extern tree_constant *builtin_freport (tree_constant *, int, int); +extern tree_constant *builtin_fscanf (tree_constant *, int, int); +extern tree_constant *builtin_fseek (tree_constant *, int, int); +extern tree_constant *builtin_fsolve (tree_constant *, int, int); +extern tree_constant *builtin_fsqp (tree_constant *, int, int); +extern tree_constant *builtin_ftell (tree_constant *, int, int); +extern tree_constant *builtin_getenv (tree_constant *, int, int); +extern tree_constant *builtin_hess (tree_constant *, int, int); +extern tree_constant *builtin_input (tree_constant *, int, int); +extern tree_constant *builtin_ifft (tree_constant *, int, int); +extern tree_constant *builtin_inv (tree_constant *, int, int); +extern tree_constant *builtin_isstr (tree_constant *, int, int); +extern tree_constant *builtin_keyboard (tree_constant *, int, int); +extern tree_constant *builtin_logm (tree_constant *, int, int); +extern tree_constant *builtin_lpsolve (tree_constant *, int, int); +extern tree_constant *builtin_lsode (tree_constant *, int, int); +extern tree_constant *builtin_lu (tree_constant *, int, int); +extern tree_constant *builtin_max (tree_constant *, int, int); +extern tree_constant *builtin_min (tree_constant *, int, int); +extern tree_constant *builtin_npsol (tree_constant *, int, int); +extern tree_constant *builtin_ones (tree_constant *, int, int); +extern tree_constant *builtin_pause (tree_constant *, int, int); +extern tree_constant *builtin_purge_tmp_files (tree_constant *, int, int); +extern tree_constant *builtin_printf (tree_constant *, int, int); +extern tree_constant *builtin_prod (tree_constant *, int, int); +extern tree_constant *builtin_pwd (tree_constant *, int, int); +extern tree_constant *builtin_qpsol (tree_constant *, int, int); +extern tree_constant *builtin_qr (tree_constant *, int, int); +extern tree_constant *builtin_quad (tree_constant *, int, int); +extern tree_constant *builtin_quit (tree_constant *, int, int); +extern tree_constant *builtin_rand (tree_constant *, int, int); +extern tree_constant *builtin_replot (tree_constant *, int, int); +extern tree_constant *builtin_setstr (tree_constant *, int, int); +extern tree_constant *builtin_scanf (tree_constant *, int, int); +extern tree_constant *builtin_schur (tree_constant *, int, int); +extern tree_constant *builtin_shell_command (tree_constant *, int, int); +extern tree_constant *builtin_size (tree_constant *, int, int); +extern tree_constant *builtin_sort (tree_constant *, int, int); +extern tree_constant *builtin_sprintf (tree_constant *, int, int); +extern tree_constant *builtin_sqrtm (tree_constant *, int, int); +extern tree_constant *builtin_sscanf (tree_constant *, int, int); +extern tree_constant *builtin_sum (tree_constant *, int, int); +extern tree_constant *builtin_sumsq (tree_constant *, int, int); +extern tree_constant *builtin_svd (tree_constant *, int, int); +extern tree_constant *builtin_warranty (tree_constant *, int, int); +extern tree_constant *builtin_zeros (tree_constant *, int, int); + +#endif + +/* +;;; Local Variables: *** +;;; mode: C++ *** +;;; page-delimiter: "^/\\*" *** +;;; End: *** +*/
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/gripes.cc Sun Aug 08 01:13:40 1993 +0000 @@ -0,0 +1,81 @@ +// gripes.cc -*- C++ -*- +/* + +Copyright (C) 1992, 1993 John W. Eaton + +This file is part of Octave. + +Octave is free software; you can redistribute it and/or modify it +under the terms of the GNU General Public License as published by the +Free Software Foundation; either version 2, or (at your option) any +later version. + +Octave is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +for more details. + +You should have received a copy of the GNU General Public License +along with Octave; see the file COPYING. If not, write to the Free +Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. + +*/ + +#ifdef __GNUG__ +#pragma implementation +#endif + +#include "gripes.h" +#include "error.h" + +void +gripe_string_invalid (void) +{ + error ("string constant used in invalid context"); +} + +void +gripe_range_invalid (void) +{ + error ("range constant used in invalid context"); +} + +void +gripe_nonconformant (void) +{ + error ("nonconformant matrices"); +} + +void +gripe_empty_arg (const char *name, int is_error) +{ + if (is_error) + error ("%s: empty matrix is invalid as an argument", name); + else + warning ("%s: argument is empty matrix", name); +} + +void +gripe_square_matrix_required (const char *name) +{ + error ("%s: argument must be a square matrix", name); +} + +void +gripe_user_supplied_eval (const char *name) +{ + error ("%s: evaluation of user-supplied function failed", name); +} + +void +gripe_user_returned_invalid (const char *name) +{ + error ("%s: user-supplied function returned invalid value", name); +} + +/* +;;; Local Variables: *** +;;; mode: C++ *** +;;; page-delimiter: "^/\\*" *** +;;; End: *** +*/
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/gripes.h Sun Aug 08 01:13:40 1993 +0000 @@ -0,0 +1,46 @@ +// gripes.h -*- C++ -*- +/* + +Copyright (C) 1992, 1993 John W. Eaton + +This file is part of Octave. + +Octave is free software; you can redistribute it and/or modify it +under the terms of the GNU General Public License as published by the +Free Software Foundation; either version 2, or (at your option) any +later version. + +Octave is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +for more details. + +You should have received a copy of the GNU General Public License +along with Octave; see the file COPYING. If not, write to the Free +Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. + +*/ + +#if !defined (_gripes_h) +#define _gripes_h 1 + +#ifdef __GNUG__ +#pragma interface +#endif + +extern void gripe_string_invalid (void); +extern void gripe_range_invalid (void); +extern void gripe_nonconformant (void); +extern void gripe_empty_arg (const char *name, int is_error); +extern void gripe_square_matrix_required (const char *name); +extern void gripe_user_supplied_eval (const char *name); +extern void gripe_user_returned_invalid (const char *name); + +#endif + +/* +;;; Local Variables: *** +;;; mode: C++ *** +;;; page-delimiter: "^/\\*" *** +;;; End: *** +*/
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/help.cc Sun Aug 08 01:13:40 1993 +0000 @@ -0,0 +1,264 @@ +// help.cc -*- C++ -*- +/* + +Copyright (C) 1992, 1993 John W. Eaton + +This file is part of Octave. + +Octave is free software; you can redistribute it and/or modify it +under the terms of the GNU General Public License as published by the +Free Software Foundation; either version 2, or (at your option) any +later version. + +Octave is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +for more details. + +You should have received a copy of the GNU General Public License +along with Octave; see the file COPYING. If not, write to the Free +Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. + +*/ + +#ifdef __GNUG__ +#pragma implementation +#endif + +#include <iostream.h> +#include "builtins.h" +#include "help.h" + +static help_list operators[] = +{ + { "!", + "Logical not operator. See also `~'.\n", }, + + { "!=", + "Logical not equals operator. See also `~' and `<>'.\n", }, + + { "\"", + "String delimiter.\n", }, + + { "#", + "Begin comment character. See also `%'.\n", }, + + { "%", + "Begin comment charcter. See also `#'.\n", }, + + { "&", + "Logical and operator. See also `&&'.\n", }, + + { "&&", + "Logical and operator. See also `&'.\n", }, + + { "'", + "Matrix transpose operator. For complex matrices, computes the\n\ +complex conjugate (Hermitian) transpose. See also `.''\n\ +\n\ +The single quote character may also be used to delimit strings, but\n\ +it is better to use the double quote character, since that is never\n\ +ambiguous\n", }, + + { "(", + "Array index or function argument delimiter.\n", }, + + { ")", + "Array index or function argument delimiter.\n", }, + + { "*", + "Multiplication operator. See also `.*'\n", }, + + { "**", + "Power operator. See also `^', `.**', and `.^'\n", }, + + { "+", + "Addition operator.\n", }, + + { "++", + "Increment operator. As in C, may be applied as a prefix or postfix operator.\n", }, + + { ",", + "Array index, function argument, or command separator.\n", }, + + { "-", + "Subtraction or unary negation operator.\n", }, + + { "--", + "Decrement operator. As in C, may be applied as a prefix or postfix operator.\n", }, + + { ".'", + "Matrix transpose operator. For complex matrices, computes the\n\ +transpose, *not* the complex conjugate transpose. See also `''.\n", }, + + { ".*", + "Element by element multiplication operator. See also `*'.\n", }, + + { ".**", + "Element by element power operator. See also `**', `^', and `.^'.\n", }, + + { "./", + "Element by element division operator. See also `/' and `\\'.\n", }, + + { ".^", + "Element by element division operator. See also `/' and `\\'.\n", }, + + { "/", + "Right division. See also `\\' and `./'.\n", }, + + { ":", + "Select entire rows or columns of matrices.\n", }, + + { ";", + "Array row or command separator. See also `,'.\n", }, + + { "<", + "Less than operator.\n", }, + + { "<=", + "Less than or equals operator.\n", }, + + { "<>", + "Logical not equals operator. See also `!=' and `~='.\n", }, + + { "=", + "Assignment operator.\n", }, + + { "==", + "Equality test operator.\n", }, + + { ">", + "Greater than operator.\n", }, + + { ">=", + "Greater than or equals operator.\n", }, + + { "[", + "Return list delimiter. See also `]'.\n", }, + + { "\\", + "Left division operator. See also `/' and `./'.\n", }, + + { "]", + "Return list delimiter. See also `['.\n", }, + + { "^", + "Power operator. See also `**', `.^', and `.**.'\n", }, + + { "|", + "Logical or operator. See also `||'.\n", }, + + { "||", + "Logical or operator. See also `|'.\n", }, + + { "~", + "Logical not operator. See also `!' and `~'.\n", }, + + { "~=", + "Logical not equals operator. See also `<>' and `!='.\n", }, + + { (char *) NULL, (char *) NULL, }, +}; + +static help_list keywords[] = +{ + { "break", + "Exit the innermost enclosing while or for loop.\n", }, + + { "continue", + "Jump to the end of the innermost enclosing while or for loop.\n", }, + + { "else", + "Alternate action for an if block.\n", }, + + { "elseif", + "Alternate conditional test for an if block.\n", }, + + { "end", + "Mark the end of any for, if, while, or function block.\n", }, + + { "endfor", + "Mark the end of a for loop.\n", }, + + { "endfunction", + "Mark the end of a function.\n", }, + + { "endif", + "Mark the end of an if block.\n", }, + + { "endwhile", + "Mark the end of a while loop.\n", }, + + { "for", + "Begin a for loop.\n", }, + + { "function", + "Begin a function body.\n", }, + + { "global", + "Declare variables to have global scope.\n", }, + + { "gplot", + "Produce 2-D plots using gnuplot-like command syntax.\n", }, + + { "gsplot", + "Produce 3-D plots using gnuplot-like command syntax.\n", }, + + { "if", + "Begin an if block.\n", }, + + { "return", + "Return from a function.\n", }, + + { "while", + "Begin a while loop.\n", }, + + { (char *) NULL, (char *) NULL, }, +}; + +char ** +names (help_list *lst, int& count) +{ + count = 0; + help_list *ptr = lst; + while (ptr->name != (char *) NULL) + { + count++; + ptr++; + } + + if (count == 0) + return (char **) NULL; + + char **name_list = new char * [count+1]; + + ptr = lst; + int i = 0; + while (ptr->name != (char *) NULL) + { + name_list[i++] = ptr->name; + ptr++; + } + + name_list[count] = (char *) NULL; + return name_list; +} + +help_list * +operator_help (void) +{ + return operators; +} + +help_list * +keyword_help (void) +{ + return keywords; +} + +/* +;;; Local Variables: *** +;;; mode: C++ *** +;;; page-delimiter: "^/\\*" *** +;;; End: *** +*/
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/help.h Sun Aug 08 01:13:40 1993 +0000 @@ -0,0 +1,48 @@ +// help.h -*- C++ -*- +/* + +Copyright (C) 1992, 1993 John W. Eaton + +This file is part of Octave. + +Octave is free software; you can redistribute it and/or modify it +under the terms of the GNU General Public License as published by the +Free Software Foundation; either version 2, or (at your option) any +later version. + +Octave is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +for more details. + +You should have received a copy of the GNU General Public License +along with Octave; see the file COPYING. If not, write to the Free +Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. + +*/ + +#if !defined (_help_h) +#define _help_h 1 + +#ifdef __GNUG__ +#pragma interface +#endif + +typedef struct help_list +{ + char *name; + char *help; +}; + +extern char **names (help_list *l, int& count); +extern help_list *operator_help (void); +extern help_list *keyword_help (void); + +#endif + +/* +;;; Local Variables: *** +;;; mode: C++ *** +;;; page-delimiter: "^/\\*" *** +;;; End: *** +*/
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/hess.cc Sun Aug 08 01:13:40 1993 +0000 @@ -0,0 +1,164 @@ +// tc-hess.cc -*- C++ -*- +/* + +Copyright (C) 1993 John W. Eaton + +This file is part of Octave. + +Octave is free software; you can redistribute it and/or modify it +under the terms of the GNU General Public License as published by the +Free Software Foundation; either version 2, or (at your option) any +later version. + +Octave is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +for more details. + +You should have received a copy of the GNU General Public License +along with Octave; see the file COPYING. If not, write to the Free +Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. + +*/ + +#ifdef __GNUG__ +#pragma implementation +#endif + +#include "Matrix.h" + +#include "tree-const.h" +#include "user-prefs.h" +#include "error.h" +#include "gripes.h" + +#ifdef WITH_DLD +tree_constant * +builtin_hess_2 (tree_constant *args, int nargin, int nargout) +{ + return hess (args, nargin, nargout); +} +#endif + +tree_constant * +hess (tree_constant *args, int nargin, int nargout) +{ + tree_constant *retval = NULL_TREE_CONST; + + tree_constant arg = args[1].make_numeric (); + + int a_nr = arg.rows (); + int a_nc = arg.columns (); + + if (a_nr == 0 || a_nc == 0) + { + int flag = user_pref.propagate_empty_matrices; + if (flag != 0) + { + if (flag < 0) + warning ("hess: argument is empty matrix"); + Matrix m; + retval = new tree_constant [3]; + retval[0] = tree_constant (m); + retval[1] = tree_constant (m); + } + else + error ("hess: empty matrix is invalid as argument"); + + return retval; + } + + if (a_nr != a_nc) + { + gripe_square_matrix_required ("hess"); + return retval; + } + + Matrix tmp; + ComplexMatrix ctmp; + + switch (arg.const_type ()) + { + case tree_constant_rep::matrix_constant: + { + tmp = arg.matrix_value (); + + HESS result (tmp); + + if (nargout == 1) + { + retval = new tree_constant [2]; + retval[0] = tree_constant (result.hess_matrix ()); + } + else + { + retval = new tree_constant [3]; + retval[0] = tree_constant (result.unitary_hess_matrix ()); + retval[1] = tree_constant (result.hess_matrix ()); + } + } + break; + case tree_constant_rep::complex_matrix_constant: + { + ctmp = arg.complex_matrix_value (); + + ComplexHESS result (ctmp); + + if (nargout == 1) + { + retval = new tree_constant [2]; + retval[0] = tree_constant (result.hess_matrix ()); + } + else + { + retval = new tree_constant [3]; + retval[0] = tree_constant (result.unitary_hess_matrix ()); + retval[1] = tree_constant (result.hess_matrix ()); + } + } + break; + case tree_constant_rep::scalar_constant: + { + double d = arg.double_value (); + if (nargout == 1) + { + retval = new tree_constant [2]; + retval[0] = tree_constant (d); + } + else + { + retval = new tree_constant [3]; + retval[0] = tree_constant (1); + retval[1] = tree_constant (d); + } + } + break; + case tree_constant_rep::complex_scalar_constant: + { + Complex c = arg.complex_value (); + if (nargout == 1) + { + retval = new tree_constant [2]; + retval[0] = tree_constant (c); + } + else + { + retval = new tree_constant [3]; + retval[0] = tree_constant (1); + retval[1] = tree_constant (c); + } + } + break; + default: + panic_impossible (); + break; + } + return retval; +} + +/* +;;; Local Variables: *** +;;; mode: C++ *** +;;; page-delimiter: "^/\\*" *** +;;; End: *** +*/
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/ifft.cc Sun Aug 08 01:13:40 1993 +0000 @@ -0,0 +1,101 @@ +// tc-ifft.cc -*- C++ -*- +/* + +Copyright (C) 1993 John W. Eaton + +This file is part of Octave. + +Octave is free software; you can redistribute it and/or modify it +under the terms of the GNU General Public License as published by the +Free Software Foundation; either version 2, or (at your option) any +later version. + +Octave is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +for more details. + +You should have received a copy of the GNU General Public License +along with Octave; see the file COPYING. If not, write to the Free +Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. + +*/ + +#ifdef __GNUG__ +#pragma implementation +#endif + +#include "Matrix.h" + +#include "tree-const.h" +#include "user-prefs.h" +#include "gripes.h" +#include "error.h" + +#ifdef WITH_DLD +tree_constant * +builtin_ifft_2 (tree_constant *args, int nargin, int nargout) +{ + tree_constant *retval = new tree_constant [2]; + retval[0] = ifft (args[1]); + return retval; +} +#endif + +tree_constant +ifft (tree_constant& a) +{ + tree_constant retval; + + tree_constant tmp = a.make_numeric ();; + + if (tmp.rows () == 0 || tmp.columns () == 0) + { + int flag = user_pref.propagate_empty_matrices; + if (flag != 0) + { + if (flag < 0) + gripe_empty_arg ("ifft", 0); + Matrix m; + retval = tree_constant (m); + } + else + gripe_empty_arg ("ifft", 1); + + return retval; + } + + switch (tmp.const_type ()) + { + case tree_constant_rep::matrix_constant: + { + Matrix m = tmp.matrix_value (); + ComplexMatrix mifft = m.ifourier (); + retval = tree_constant (mifft); + } + break; + case tree_constant_rep::complex_matrix_constant: + { + ComplexMatrix m = tmp.complex_matrix_value (); + ComplexMatrix mifft = m.ifourier (); + retval = tree_constant (mifft); + } + break; + case tree_constant_rep::scalar_constant: + case tree_constant_rep::complex_scalar_constant: + error ("ifft: invalid scalar arguement"); + break; + default: + panic_impossible (); + break; + } + return retval; +} + + +/* +;;; Local Variables: *** +;;; mode: C++ *** +;;; page-delimiter: "^/\\*" *** +;;; End: *** +*/
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/input.cc Sun Aug 08 01:13:40 1993 +0000 @@ -0,0 +1,342 @@ +// input.cc -*- C++ -*- +/* + +Copyright (C) 1992, 1993 John W. Eaton + +This file is part of Octave. + +Octave is free software; you can redistribute it and/or modify it +under the terms of the GNU General Public License as published by the +Free Software Foundation; either version 2, or (at your option) any +later version. + +Octave is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +for more details. + +You should have received a copy of the GNU General Public License +along with Octave; see the file COPYING. If not, write to the Free +Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. + +*/ + +// Use the GNU readline library for command line editing and hisory. + +#ifdef __GNUG__ +#pragma implementation +#endif + +#include <stdio.h> +#include <stdlib.h> +#include <strings.h> +#include <assert.h> + +// This must come before anything that includes iostream.h... +extern "C" +{ +#include "readline/readline.h" + +/* + * Yes, this sucks, but it avoids a conflict with another readline + * function declared in iostream.h. + */ +#if 0 +#define LINE_SIZE 8192 +static int no_line_editing = 1; +#endif + +char * +gnu_readline (char *s) +{ +#if 0 + static int state = 0; + static char *line_from_stdin = (char *) NULL; + if (no_line_editing) + { + if (! state) + { + line_from_stdin = (char *) malloc (LINE_SIZE); + state = 1; + } + fputs ("octave> ", stdout); + fgets (line_from_stdin, LINE_SIZE, stdin); + return line_from_stdin; + } + else +#endif + return readline (s); +} +} + +#include "variables.h" +#include "error.h" +#include "utils.h" +#include "input.h" +#include "pager.h" +#include "help.h" +#include "symtab.h" +#include "octave-hist.h" +#include "sighandlers.h" +#include "parse.h" +#include "user-prefs.h" +#include "builtins.h" + +// Global pointer for eval(). +char *current_eval_string = (char *) NULL; + +// Nonzero means get input from current_eval_string. +int get_input_from_eval_string = 0; + +// Nonzero means we're parsing an M-file. +int reading_m_file = 0; + +// Simple name of M-file we are reading. +char *curr_m_file_name = (char *) NULL; + +// Nonzero means we're parsing a script file. +int reading_script_file = 0; + +// If we are reading from an M-file, this is it. +FILE *mf_instream = (FILE *) NULL; + +// Nonzero means we are using readline. +int using_readline = 1; + +// Nonzero means commands are echoed as they are executed (-x). +int echo_input = 0; + +// Nonzero means this is an interactive shell. +int interactive = 0; + +// Nonzero means the user forced this shell to be interactive (-i). +int forced_interactive = 0; + +// Should we issue a prompt? +int promptflag = 1; + +// The current line of input, from wherever. +char *current_input_line = (char *) NULL; + +// A line of input from readline. +static char *octave_gets_line = (char *) NULL; + +/* + * Use GNU readline to get an input line and store it in the history + * list. + */ +char * +octave_gets (void) +{ + if (octave_gets_line != NULL) + free (octave_gets_line); + + if (interactive || forced_interactive) + { + char *ps = (promptflag > 0) ? user_pref.ps1 : user_pref.ps2; + char *prompt = decode_prompt_string (ps); + + if (interactive) + { + pipe_handler_error_count = 0; + flush_output_to_pager (); + } + + octave_gets_line = gnu_readline (prompt); + delete [] prompt; + } + else + octave_gets_line = gnu_readline (""); + + current_input_line = octave_gets_line; + + if (octave_gets_line && *octave_gets_line) + { + maybe_save_history (octave_gets_line); + + if (echo_input) + { + if (!forced_interactive) + cout << "+ "; + if (octave_gets_line != (char *) NULL) + cout << octave_gets_line << "\n"; + } + } + return octave_gets_line; +} + +/* + * Read a line from the input stream. + */ +int +octave_read (char *buf, int max_size) +{ + int status = 0; + + static char *stashed_line = (char *) NULL; + + if (get_input_from_eval_string) + { + int len = strlen (current_eval_string); + if (len < max_size - 1) + { + strcpy (buf, current_eval_string); + buf[len++] = '\n'; + buf[len] = '\0'; // Paranoia. + status = len; + } + else + status = -1; + + if (stashed_line) + delete [] stashed_line; + + stashed_line = strsave (buf); + current_input_line = stashed_line; + } + else if (using_readline) + { + char *cp = octave_gets (); + if (cp != (char *) NULL) + { + int len = strlen (cp); + if (len >= max_size) + status = -1; + else + { + strcpy (buf, cp); + buf[len++] = '\n'; + buf[len] = '\0'; // Paranoia. + status = len; + } + } + current_input_line = cp; + } + else + { + FILE *curr_stream = rl_instream; + if (reading_m_file || reading_script_file) + curr_stream = mf_instream; + + assert (curr_stream != (FILE *) NULL); + +// Why is this required? + buf[0] = '\0'; + + if (fgets (buf, max_size, curr_stream) != (char *) NULL) + { + int len = strlen (buf); + if (len > max_size - 2) + status = -1; + else + { + if (buf[len-1] != '\n') + { + buf[len++] = '\n'; + buf[len] = '\0'; + } + status = len; + } + } + else + status = 0; // Tell yylex that we found EOF. + + if (stashed_line) + delete [] stashed_line; + + stashed_line = strsave (buf); + current_input_line = stashed_line; + } + input_line_number++; + return status; +} + +/* + * Fix things up so that input can come from file `name', printing a + * warning if the file doesn't exist. + */ +FILE * +get_input_from_file (char *name, int warn = 1) +{ + FILE *instream = (FILE *) NULL; + + if (name && *name) + instream = fopen (name, "r"); + + if (instream == (FILE *) NULL && warn) + message (name, "no such file or directory"); + + if (reading_m_file || reading_script_file) + mf_instream = instream; + else + rl_instream = instream; + + return instream; +} + +/* + * Fix things up so that input can come from the standard input. This + * may need to become much more complicated, which is why it's in a + * separate function. + */ +FILE * +get_input_from_stdin (void) +{ + rl_instream = stdin; + return rl_instream; +} + +char * +command_generator (char *text, int state) +{ + static int len = 0; + static int list_index = 0; + + static char **name_list = (char **) NULL; + + if (state == 0) + { + list_index = 0; + len = strlen (text); + + if (name_list != (char **) NULL) + delete [] name_list; + + name_list = make_name_list (); + } + + char *name; + while ((name = name_list[list_index]) != (char *) NULL) + { + list_index++; + if (strncmp (name, text, len) == 0) + return name; + } + + return (char *) NULL; +} + +char ** +command_completer (char *text, int start, int end) +{ + char **matches = (char **) NULL; + matches = completion_matches (text, command_generator); + return matches; +} + +void +initialize_readline (void) +{ +// Allow conditional parsing of the ~/.inputrc file + rl_readline_name = "Octave"; + +// Tell the completer that we want to try first. + rl_attempted_completion_function = (Function *) command_completer; +} + +/* +;;; Local Variables: *** +;;; mode: C++ *** +;;; page-delimiter: "^/\\*" *** +;;; End: *** +*/
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/input.h Sun Aug 08 01:13:40 1993 +0000 @@ -0,0 +1,91 @@ +// input.h -*- C++ -*- +/* + +Copyright (C) 1992, 1993 John W. Eaton + +This file is part of Octave. + +Octave is free software; you can redistribute it and/or modify it +under the terms of the GNU General Public License as published by the +Free Software Foundation; either version 2, or (at your option) any +later version. + +Octave is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +for more details. + +You should have received a copy of the GNU General Public License +along with Octave; see the file COPYING. If not, write to the Free +Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. + +*/ + +// Use the GNU readline library for command line editing and hisory. + +#if !defined (_input_h) +#define _input_h 1 + +#ifdef __GNUG__ +#pragma interface +#endif + +#include <stdio.h> + +extern char *octave_gets (void); +extern int octave_read (char *buf, int max_size); +extern FILE *get_input_from_file (char *name, int warn = 1); +extern FILE *get_input_from_stdin (void); +extern char *command_generator (char *text, int state); +extern char **command_completer (char *text, int start, int end); +extern void initialize_readline (void); + +// Global pointer for eval(). +extern char *current_eval_string; + +// Nonzero means get input from current_eval_string. +extern int get_input_from_eval_string; + +// Nonzero means we're parsing an M-file. +extern int reading_m_file; + +// Simple name of M-file we are reading. +extern char *curr_m_file_name; + +// Nonzero means we're parsing a script file. +extern int reading_script_file; + +// If we are reading from an M-file, this is it. +extern FILE *mf_instream; + +// Nonzero means we are using readline. +extern int using_readline; + +// Nonzero means commands are echoed as they are executed (-x). +extern int echo_input; + +// Nonzero means this is an interactive shell. +extern int interactive; + +// Nonzero means the user forced this shell to be interactive (-i). +extern int forced_interactive; + +// Should we issue a prompt? +extern int promptflag; + +// A line of input. +extern char *current_input_line; + +extern "C" +{ +char *gnu_readline (char *s); +} + +#endif + +/* +;;; Local Variables: *** +;;; mode: C++ *** +;;; page-delimiter: "^/\\*" *** +;;; End: *** +*/
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/inv.cc Sun Aug 08 01:13:40 1993 +0000 @@ -0,0 +1,130 @@ +// tc-inv.cc -*- C++ -*- +/* + +Copyright (C) 1993 John W. Eaton + +This file is part of Octave. + +Octave is free software; you can redistribute it and/or modify it +under the terms of the GNU General Public License as published by the +Free Software Foundation; either version 2, or (at your option) any +later version. + +Octave is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +for more details. + +You should have received a copy of the GNU General Public License +along with Octave; see the file COPYING. If not, write to the Free +Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. + +*/ + +#ifdef __GNUG__ +#pragma implementation +#endif + +#include "Matrix.h" + +#include "tree-const.h" +#include "user-prefs.h" +#include "gripes.h" +#include "error.h" + +#ifdef WITH_DLD +tree_constant * +builtin_inv (tree_constant *args, int nargin, int nargout) +{ + tree_constant *retval = new tree_constant [2]; + retval[0] = inverse (args[1]); + return retval; +} +#endif + +tree_constant +inverse (tree_constant& a) +{ + tree_constant retval; + + tree_constant tmp = a.make_numeric (); + + int nr = tmp.rows (); + int nc = tmp.columns (); + if (nr == 0 || nc == 0) + { + int flag = user_pref.propagate_empty_matrices; + if (flag < 0) + gripe_empty_arg ("inverse", 0); + else if (flag == 0) + gripe_empty_arg ("inverse", 1); + } + + Matrix mtmp; + if (nr == 0 && nc == 0) + return tree_constant (mtmp); + + switch (tmp.const_type ()) + { + case tree_constant_rep::matrix_constant: + { + Matrix m = tmp.matrix_value (); + if (m.rows () == m.columns ()) + { + int info; + double rcond = 0.0; + Matrix minv = m.inverse (info, rcond); + if (info == -1) + message ("inverse", + "matrix singular to machine precision, rcond = %g", + rcond); + else + retval = tree_constant (minv); + } + else + gripe_square_matrix_required ("inverse"); + } + break; + case tree_constant_rep::scalar_constant: + { + double d = 1.0 / tmp.double_value (); + retval = tree_constant (d); + } + break; + case tree_constant_rep::complex_matrix_constant: + { + ComplexMatrix m = tmp.complex_matrix_value (); + if (m.rows () == m.columns ()) + { + int info; + double rcond = 0.0; + ComplexMatrix minv = m.inverse (info, rcond); + if (info == -1) + message ("inverse", + "matrix singular to machine precision, rcond = %g", + rcond); + else + retval = tree_constant (minv); + } + else + gripe_square_matrix_required ("inverse"); + } + break; + case tree_constant_rep::complex_scalar_constant: + { + Complex c = 1.0 / tmp.complex_value (); + retval = tree_constant (c); + } + break; + default: + break; + } + return retval; +} + +/* +;;; Local Variables: *** +;;; mode: C++ *** +;;; page-delimiter: "^/\\*" *** +;;; End: *** +*/
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/lex.h Sun Aug 08 01:13:40 1993 +0000 @@ -0,0 +1,57 @@ +// lex.h -*- C++ -*- +/* + +Copyright (C) 1992, 1993 John W. Eaton + +This file is part of Octave. + +Octave is free software; you can redistribute it and/or modify it +under the terms of the GNU General Public License as published by the +Free Software Foundation; either version 2, or (at your option) any +later version. + +Octave is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +for more details. + +You should have received a copy of the GNU General Public License +along with Octave; see the file COPYING. If not, write to the Free +Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. + +*/ + +#if !defined (_lex_h) +#define _lex_h 1 + +typedef struct yy_buffer_state *YY_BUFFER_STATE; + +// Associate a buffer with a new file to read. +extern YY_BUFFER_STATE create_buffer (FILE *f); + +// Report the current buffer. +extern YY_BUFFER_STATE current_buffer (void); + +// Connect to new buffer buffer. +extern void switch_to_buffer (YY_BUFFER_STATE buf); + +// Delete a buffer. +extern void delete_buffer (YY_BUFFER_STATE buf); + +// Restore a buffer (for unwind-prot). +extern void restore_input_buffer (void *buf); + +// Delete a buffer (for unwind-prot). +extern void delete_input_buffer (void *buf); + +// See if a function file has extra garbage after the end statement. +extern void check_for_garbage_after_fcn_def (void); + +#endif + +/* +;;; Local Variables: *** +;;; mode: C++ *** +;;; page-delimiter: "^/\\*" *** +;;; End: *** +*/
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/lex.l Sun Aug 08 01:13:40 1993 +0000 @@ -0,0 +1,1340 @@ +/* lex.l -*- C -*- + +Copyright (C) 1992, 1993 John W. Eaton + +This file is part of Octave. + +Octave is free software; you can redistribute it and/or modify it +under the terms of the GNU General Public License as published by the +Free Software Foundation; either version 2, or (at your option) any +later version. + +Octave is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +for more details. + +You should have received a copy of the GNU General Public License +along with GNU CC; see the file COPYING. If not, write to the Free +Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. + +*/ + +%x COMMENT +%x NEW_MATRIX +%x HELP_FCN +%s TEXT_FCN +%s DQSTRING +%s STRING +%s MATRIX + +%{ + +// Arrange to get input via readline. + +#ifdef YY_INPUT +#undef YY_INPUT +#define YY_INPUT(buf,result,max_size) \ + if ((result = octave_read (buf, max_size)) < 0) \ + YY_FATAL_ERROR ("octave_read () in flex scanner failed"); +#endif + +// Try to avoid crashing out completely on fatal scanner errors. + +#ifdef YY_FATAL_ERROR +#undef YY_FATAL_ERROR +#define YY_FATAL_ERROR(msg) \ + do \ + { \ + error (msg); \ + jump_to_top_level (); \ + } \ + while (0) +#endif + +#include "input.h" + +// The type of an END token. This declaration is repeated in parse.y. +// It must appear before y.tab.h is included. +enum end_tok_type + { + simple_end, + for_end, + function_end, + if_end, + while_end, + }; + +// The type of a PLOT token. This declaration is repeated in parse.y. +// It must appear before y.tab.h is included. +enum plot_tok_type + { + two_dee = 2, + three_dee = 3, + }; + +#include "SLStack.h" + +#include "variables.h" +#include "symtab.h" +#include "error.h" +#include "utils.h" +#include "tree.h" +#include "y.tab.h" +#include "parse.h" +#include "lex.h" + +// Nonzero means we thing we are looking at the beginning of a +// function definition. +static int beginning_of_function = 0; + +// Nonzero means we think we are looking at a set command. +static int doing_set = 0; + +// GAG. Stupid kludge so that [[1,2][3,4]] will work. +static do_comma_insert = 0; + +// Brace level count. +static int braceflag = 0; + +// Return transpose or start a string? +static int quote_is_transpose = 0; + +// Nonzero means that we should convert spaces to a comma inside a +// matrix definition. +static int convert_spaces_to_comma = 1; + +// Another context hack, this time for the plot command's `using', +// `title', and `with' keywords. +static int cant_be_identifier = 0; + +// Is the closest nesting level a square brace or a paren? +// +// 1 -> brace, spaces are important (they can turn into commas) +// 0 -> paren, spaces are not important +// +static SLStack <int> in_brace_or_paren; + +static void do_string_escapes (char *s); +static void fixup_column_count (char *s); +static int do_comma_insert_check (void); +static int is_plot_keyword (char *s); +static int is_keyword (char *s); +static char *plot_style_token (char *s); +static symbol_record *lookup_identifier (char *s); +static void grab_help_text (void); +static int match_any (char c, char *s); +static int next_token_is_bin_op (int spc_prev, char *yytext); +static int next_token_is_postfix_unary_op (int spc_prev, char *yytext); +static char *strip_trailing_whitespace (char *s); + +#define DO_COMMA_INSERT_CHECK yyless (do_comma_insert_check ()) + +#define RETURN(token) \ + do \ + { \ + current_input_column += yyleng; \ + quote_is_transpose = 0; \ + cant_be_identifier = 0; \ + convert_spaces_to_comma = 1; \ + return (token); \ + } \ + while (0) + +#define BIN_OP_RETURN(token) \ + do \ + { \ + current_input_column += yyleng; \ + quote_is_transpose = 0; \ + cant_be_identifier = 0; \ + convert_spaces_to_comma = 0; \ + return (token); \ + } \ + while (0) + +%} + +D [0-9] +S [ \t] +N [\n] +SN [ \t\n] +EL (\.\.\.) +Im [iIjJ] +QQ (\'\') +ECHAR (\\.) +QSTR ([^\n\'\\]*({QQ}|{ECHAR})*) +DQSTR ([^\n\"\\]*{ECHAR}*) +IDENT ([_a-zA-Z][_a-zA-Z0-9]*) +EXPON ([DdEe][+-]?{D}+) +%% + +\% | +\# { + if (beginning_of_function) + { + grab_help_text (); + beginning_of_function = 0; + } + + BEGIN COMMENT; + current_input_column += yyleng; + } + +<COMMENT>\n { + BEGIN 0; + current_input_column = 0; + quote_is_transpose = 0; + cant_be_identifier = 0; + convert_spaces_to_comma = 1; + return '\n'; + } + +<COMMENT><<EOF>> { RETURN (END_OF_INPUT); } + +<COMMENT>.*$ { current_input_column += yyleng; } + +<NEW_MATRIX>[^ \t\n] { + yyless (0); + BEGIN MATRIX; + } + +<NEW_MATRIX>{SN}* { + fixup_column_count (yytext); + BEGIN MATRIX; + } + +<HELP_FCN>\n | +<TEXT_FCN>\n { + BEGIN 0; + current_input_column = 0; + quote_is_transpose = 0; + cant_be_identifier = 0; + convert_spaces_to_comma = 1; + return '\n'; + } + +<TEXT_FCN>[\;\,] { + if (doing_set) + { + yylval.string = strsave (yytext); + RETURN (TEXT); + } + else + { + BEGIN 0; + RETURN (','); + } + } + +<HELP_FCN>[^ \t\n]*{S}* | +<TEXT_FCN>[^ \t\n\;\,]*{S}* { + + static char *tok = (char *) NULL; + delete [] tok; + tok = strip_trailing_whitespace (yytext); + + yylval.string = strsave (tok); + RETURN (TEXT); + } + +<TEXT_FCN>\'{QSTR}*[\n\'] { + if (yytext[yyleng-1] == '\n') + { + error ("unterminated string constant"); + current_input_column = 0; + jump_to_top_level (); + } + else + { + int off1 = doing_set ? 0 : 1; + int off2 = doing_set ? 0 : 2; + yylval.string = strsave (&yytext[off1]); + yylval.string[yyleng-off2] = '\0'; + current_input_column += yyleng; + } + do_string_escapes (yylval.string); + return TEXT; + } + +<TEXT_FCN>\"{DQSTR}*[\n\"] { + if (yytext[yyleng-1] == '\n') + { + error ("unterminated string constant"); + current_input_column = 0; + jump_to_top_level (); + } + else + { + int off1 = doing_set ? 0 : 1; + int off2 = doing_set ? 0 : 2; + yylval.string = strsave (&yytext[off1]); + yylval.string[yyleng-off2] = '\0'; + current_input_column += yyleng; + } + do_string_escapes (yylval.string); + return TEXT; + } + +<TEXT_FCN>{S}* { current_input_column += yyleng; } + +<STRING>{QSTR}*[\n\'] { + if (braceflag) + BEGIN MATRIX; + else + BEGIN 0; + + if (yytext[yyleng-1] == '\n') + { + error ("unterminated string constant"); + current_input_column = 0; + jump_to_top_level (); + } + else + { + yylval.string = strsave (yytext); + yylval.string[yyleng-1] = '\0'; + current_input_column += yyleng; + } + do_string_escapes (yylval.string); + quote_is_transpose = 1; + cant_be_identifier = 1; + convert_spaces_to_comma = 1; + return TEXT; + } + + +<DQSTRING>{DQSTR}*[\n\"] { + if (braceflag) + BEGIN MATRIX; + else + BEGIN 0; + + if (yytext[yyleng-1] == '\n') + { + error ("unterminated string constant"); + current_input_column = 0; + jump_to_top_level (); + } + else + { + yylval.string = strsave (yytext); + yylval.string[yyleng-1] = '\0'; + current_input_column += yyleng; + } + do_string_escapes (yylval.string); + quote_is_transpose = 1; + cant_be_identifier = 1; + convert_spaces_to_comma = 1; + return TEXT; + } + +<MATRIX>{SN}*\]{S}*/== { + +// For this and the next two rules, we're looking at ']', and we +// need to know if the next token is '='. +// +// All this so we can handle the bogus syntax +// +// [x,y] % an expression by itself +// [x,y] = expression % assignment to a list of identifiers +// [x,y] == expression % test for equality +// +// It would have been so much easier if the delimiters were simply +// different for the expression on the left hand side of the equals +// operator. + + in_brace_or_paren.pop (); + braceflag--; + if (braceflag == 0) + { + if (!defining_func) + promptflag++; + BEGIN 0; + } + fixup_column_count (yytext); + quote_is_transpose = 0; + cant_be_identifier = 0; + convert_spaces_to_comma = 1; + return ']'; + } + +<MATRIX>{SN}*\]{S}*/= { + in_brace_or_paren.pop (); + braceflag--; + if (braceflag == 0) + { + BEGIN 0; + if (!defining_func) + promptflag++; + } + fixup_column_count (yytext); + quote_is_transpose = 0; + cant_be_identifier = 0; + convert_spaces_to_comma = 1; + if (maybe_screwed_again) + return SCREW_TWO; + else + return ']'; + } + +<MATRIX>{SN}*\]{S}* { + fixup_column_count (yytext); + + in_brace_or_paren.pop (); + braceflag--; + if (braceflag == 0) + { + if (!defining_func) + promptflag++; + BEGIN 0; + } + else + { + int c0 = yytext[yyleng-1]; + int spc_prev = (c0 == ' ' || c0 == '\t'); + int bin_op = next_token_is_bin_op (spc_prev, + yytext); + int postfix_un_op + = next_token_is_postfix_unary_op (spc_prev, + yytext); + + int c1 = yyinput (); + unput (c1); + int other_op = match_any (c1, ",;\n]"); + + if (! (postfix_un_op || bin_op || other_op) + && in_brace_or_paren.top () + && convert_spaces_to_comma) + { + unput (','); + return ']'; + } + } + + quote_is_transpose = 1; + cant_be_identifier = 0; + convert_spaces_to_comma = 1; + return ']'; + } + +<MATRIX>{S}*\,{S}* { RETURN (','); } + +<MATRIX>{S}+ { + int bin_op = next_token_is_bin_op (1, yytext); + int postfix_un_op + = next_token_is_postfix_unary_op (1, yytext); + + if (! (postfix_un_op || bin_op) + && in_brace_or_paren.top () + && convert_spaces_to_comma) + RETURN (','); + } + +<MATRIX>{SN}*\;{SN}* | +<MATRIX>{N}{SN}* { + fixup_column_count (yytext); + quote_is_transpose = 0; + cant_be_identifier = 0; + convert_spaces_to_comma = 1; + return ';'; + } + +\] { + if (! in_brace_or_paren.empty ()) + in_brace_or_paren.pop (); + + if (plotting) + { + in_plot_range = 0; + RETURN (CLOSE_BRACE); + } + else + RETURN (']'); + } + +{D}+{EXPON}?{Im} | +{D}+\.{D}*{EXPON}?{Im} | +\.{D}+{EXPON}?{Im} { + int nread = sscanf (yytext, "%lf", &(yylval.number)); + assert (nread == 1); + quote_is_transpose = 1; + cant_be_identifier = 1; + convert_spaces_to_comma = 1; + current_input_column += yyleng; + DO_COMMA_INSERT_CHECK; + return IMAG_NUM; + } + +{D}+{EXPON}? | +{D}+\.{D}*{EXPON}? | +\.{D}+{EXPON}? | + { + int nread = sscanf (yytext, "%lf", &(yylval.number)); + assert (nread == 1); + quote_is_transpose = 1; + cant_be_identifier = 1; + convert_spaces_to_comma = 1; + current_input_column += yyleng; + DO_COMMA_INSERT_CHECK; + return NUM; + } + +\[{S}* { + in_brace_or_paren.push (1); + if (plotting) + { + in_plot_range = 1; + RETURN (OPEN_BRACE); + } + + if (do_comma_insert) + { + yyless (0); + do_comma_insert = 0; + quote_is_transpose = 0; + cant_be_identifier = 0; + convert_spaces_to_comma = 1; + return (','); + } + else + { + mlnm.push (1); + braceflag++; + promptflag--; + BEGIN NEW_MATRIX; + RETURN ('['); + } + } + +{S}* { current_input_column += yyleng; } + +{EL}{S}*\n { + +// Line continuation. + + promptflag--; + current_input_column = 0; + } + +<<EOF>> RETURN (END_OF_INPUT); + +{IDENT}{S}* { + +// Truncate the token at the first space or tab but don't write +// directly on yytext. + + static char *tok = (char *) NULL; + delete [] tok; + tok = strip_trailing_whitespace (yytext); + + int kw_token = is_keyword (tok); + if (kw_token) + RETURN (kw_token); + + if (plotting && cant_be_identifier) + { + int plot_option_kw = is_plot_keyword (tok); + if (plot_option_kw) + { + quote_is_transpose = 0; + cant_be_identifier = 0; + convert_spaces_to_comma = 1; + current_input_column += yyleng; + return plot_option_kw; + } + } + + if (plotting && in_plot_style) + { + char *sty = plot_style_token (&tok[1]); + if (sty != (char *) NULL) + { + yylval.string = strsave (sty); + if (in_plot_style) + { + in_plot_style = 0; + RETURN (STYLE); + } + } + } + + cant_be_identifier = 1; + +// If we are looking at a text style function, set up to gobble its +// arguments. These are also reserved words, but only because it +// would be very difficult to do anything intelligent with them if +// they were not reserved. + + if (is_text_function_name (tok)) + { + BEGIN TEXT_FCN; + + if (strcmp (tok, "clear") == 0) + return CLEAR; + else if (strcmp (tok, "help") == 0) + BEGIN HELP_FCN; + else if (strcmp (tok, "set") == 0) + doing_set = 1; + } + + yylval.sym_rec = lookup_identifier (tok); + + quote_is_transpose = 1; + current_input_column += yyleng; + DO_COMMA_INSERT_CHECK; + + if (! in_brace_or_paren.empty () + && in_brace_or_paren.top ()) + { + int c0 = yytext[yyleng-1]; + int spc_prev = (c0 == ' ' || c0 == '\t'); + int bin_op = next_token_is_bin_op (spc_prev, yytext); + + int postfix_un_op + = next_token_is_postfix_unary_op (spc_prev, yytext); + + int c1 = yyinput (); + unput (c1); + int other_op = match_any (c1, ",;\n]("); + + if (! (postfix_un_op || bin_op || other_op)) + unput (','); + } + + convert_spaces_to_comma = 1; + return NAME; + } + +{IDENT}/{S}*= { + +// We've found an identifier followed by some space and an equals +// sign. If we are working on a function definition and the previous +// token was `function', we have something like this +// +// function x = y <list> end +// +// which is a function named y returning a variable named x. The +// symbol y belongs in the global symbol table (nested function +// definitions are illegal) and the symbol x belongs in the +// symbol table local to the function. +// +// If we're not defining a function, this should function exactly like +// the case above. I suppose it would be nice to avoid duplicating +// all the code, eh? + + int kw_token = is_keyword (yytext); + if (kw_token) + RETURN (kw_token); + + if (plotting && cant_be_identifier) + { + int plot_option_kw = is_plot_keyword (yytext); + if (plot_option_kw) + { + quote_is_transpose = 0; + convert_spaces_to_comma = 1; + current_input_column += yyleng; + return plot_option_kw; + } + } + + cant_be_identifier = 1; + +// If we are looking at a text style function, set up to gobble its +// arguments. These are also reserved words, but only because it +// would be very difficult to do anything intelligent with them if +// they were not reserved. + + if (is_text_function_name (yytext)) + { + BEGIN TEXT_FCN; + + if (strcmp (yytext, "clear") == 0) + return CLEAR; + else if (strcmp (yytext, "help") == 0) + BEGIN HELP_FCN; + else if (strcmp (yytext, "set") == 0) + doing_set = 1; + } + + if (defining_func && maybe_screwed) + curr_sym_tab = tmp_local_sym_tab; + + yylval.sym_rec = lookup_identifier (yytext); + + convert_spaces_to_comma = 1; + current_input_column += yyleng; + if (defining_func && maybe_screwed) + { + return SCREW; + } + else + { + quote_is_transpose = 1; + DO_COMMA_INSERT_CHECK; + return NAME; + } + } + +"\n" { + quote_is_transpose = 0; + cant_be_identifier = 0; + current_input_column = 0; + convert_spaces_to_comma = 1; + return '\n'; + } + +"'" { + current_input_column++; + convert_spaces_to_comma = 1; + + if (quote_is_transpose) + { + DO_COMMA_INSERT_CHECK; + return QUOTE; + } + else + BEGIN STRING; + } + +":" { + if (plotting && (in_plot_range || in_plot_using)) + RETURN (COLON); + else + BIN_OP_RETURN (':'); + } + +\" { BEGIN DQSTRING; } +".**" { BIN_OP_RETURN (EPOW); } +".*" { BIN_OP_RETURN (EMUL); } +"./" { BIN_OP_RETURN (EDIV); } +".\\" { BIN_OP_RETURN (ELEFTDIV); } +".^" { BIN_OP_RETURN (EPOW); } +".'" { DO_COMMA_INSERT_CHECK; RETURN (TRANSPOSE); } +"++" { DO_COMMA_INSERT_CHECK; RETURN (PLUS_PLUS); } +"--" { DO_COMMA_INSERT_CHECK; RETURN (MINUS_MINUS); } +"<=" { BIN_OP_RETURN (EXPR_LE); } +"==" { BIN_OP_RETURN (EXPR_EQ); } +"~=" { BIN_OP_RETURN (EXPR_NE); } +"!=" { BIN_OP_RETURN (EXPR_NE); } +"<>" { BIN_OP_RETURN (EXPR_NE); } +">=" { BIN_OP_RETURN (EXPR_GE); } +"||" { BIN_OP_RETURN (EXPR_OR); } +"&&" { BIN_OP_RETURN (EXPR_AND); } +"|" { BIN_OP_RETURN (EXPR_OR); } +"&" { BIN_OP_RETURN (EXPR_AND); } +"!" { RETURN (EXPR_NOT); } +"~" { BIN_OP_RETURN (EXPR_NOT); } +"<" { BIN_OP_RETURN (EXPR_LT); } +">" { BIN_OP_RETURN (EXPR_GT); } +"+" { BIN_OP_RETURN ('+'); } +"-" { BIN_OP_RETURN ('-'); } +"**" { BIN_OP_RETURN (POW); } +"*" { BIN_OP_RETURN ('*'); } +"/" { BIN_OP_RETURN ('/'); } +"\\" { BIN_OP_RETURN (LEFTDIV); } +";" { RETURN (';'); } +"," { RETURN (','); } +"^" { BIN_OP_RETURN (POW); } +"=" { RETURN ('='); } +"(" { + in_brace_or_paren.push (0); + RETURN ('('); + } +")" { + if (! in_brace_or_paren.empty ()) + in_brace_or_paren.pop (); + DO_COMMA_INSERT_CHECK; + current_input_column++; + quote_is_transpose = 1; + return ')'; + } + +. { + +// We return everything else as single character tokens, which should +// eventually result in a parse error. + + RETURN (yytext[0]); + } + +%% + +/* + * GAG. + * + * If we're reading a matrix and the next character is '[', make sure + * that we insert a comma ahead of it. + */ +int +do_comma_insert_check (void) +{ + int tmp_len = yyleng; + int c = yyinput (); + do_comma_insert = (braceflag && c == '['); + return tmp_len; +} + +/* + * Fix things up for errors or interrupts. + */ +void +reset_parser (void) +{ + BEGIN 0; + promptflag = 1; + doing_set = 0; + braceflag = 0; + maybe_screwed = 0; + maybe_screwed_again = 0; + looping = 0; + iffing = 0; + ml.clear (); + mlnm.clear (); + defining_func = 0; + curr_sym_tab = top_level_sym_tab; + get_input_from_eval_string = 0; + quote_is_transpose = 0; + current_input_column = 0; + do_comma_insert = 0; + plotting = 0; + in_plot_range = 0; + in_plot_using = 0; + in_plot_style = 0; + cant_be_identifier = 0; + convert_spaces_to_comma = 1; + beginning_of_function = 0; + in_brace_or_paren.clear (); + yyrestart (stdin); +} + +static void +do_string_escapes (char *s) +{ + char *p1 = s; + char *p2 = s; + while (*p2 != '\0') + { + if (*p2 == '\\' && *(p2+1) != '\0') + { + switch (*++p2) + { + case 'a': + *p1 = '\a'; + break; + case 'b': // backspace + *p1 = '\b'; + break; + case 'f': // formfeed + *p1 = '\f'; + break; + case 'n': // newline + *p1 = '\n'; + break; + case 'r': // carriage return + *p1 = '\r'; + break; + case 't': // horizontal tab + *p1 = '\t'; + break; + case 'v': // vertical tab + *p1 = '\v'; + break; + case '\\': // backslash + *p1 = '\\'; + break; + case '\'': // quote + *p1 = '\''; + break; + case '"': // double quote + *p1 = '"'; + break; + default: + warning ("unrecognized escape sequence `\\%c' -- converting to `%c'", + *p2, *p2); + *p1 = *p2; + break; + } + } + else if (*p2 == '\'' && *(p2+1) == '\'') + { + *p1 = '\''; + p2++; + } + else + { + *p1 = *p2; + } + + p1++; + p2++; + } + + *p1 = '\0'; +} + +static void +fixup_column_count (char *s) +{ + char c; + while ((c = *s++) != '\0') + { + if (c == '\n') + current_input_column = 0; + else + current_input_column++; + } +} + +#ifdef yywrap +#undef yywrap +#endif +int +yywrap (void) +{ + return 0; +} + +/* + * Tell us all what the current buffer is. + */ +YY_BUFFER_STATE +current_buffer (void) +{ + return YY_CURRENT_BUFFER; +} + +/* + * Create a new buffer. + */ +YY_BUFFER_STATE +create_buffer (FILE *f) +{ + return yy_create_buffer (f, YY_BUF_SIZE); +} + +/* + * Start reading a new buffer. + */ +void +switch_to_buffer (YY_BUFFER_STATE buf) +{ + yy_switch_to_buffer (buf); +} + +/* + * Delete a buffer. + */ +void +delete_buffer (YY_BUFFER_STATE buf) +{ + yy_delete_buffer (buf); +} + +/* + * Restore a buffer (for unwind-prot). + */ +void +restore_input_buffer (void *buf) +{ + switch_to_buffer ((YY_BUFFER_STATE) buf); +} + +/* + * Delete a buffer (for unwind-prot). + */ +void +delete_input_buffer (void *buf) +{ + delete_buffer ((YY_BUFFER_STATE) buf); +} + +static char *plot_styles[] = + { + "dots", + "dots", + "errorbars", + "impulses", + "lines", + "linespoints", + "points", + (char *) NULL, + }; + +static char * +plot_style_token (char *s) +{ + char **tmp = plot_styles; + while (*tmp != (char *) NULL) + { + if (almost_match (*tmp, s)) + return *tmp; + + tmp++; + } + + return (char *) NULL; +} + +static int +is_plot_keyword (char *s) +{ + if (almost_match ("title", s)) + return TITLE; + else if (almost_match ("using", s)) + { in_plot_using = 1; return USING; } + else if (almost_match ("with", s)) + { in_plot_style = 1; return WITH; } + else + return 0; +} + +/* + * Handle keywords. Could probably be more efficient... + */ +static int +is_keyword (char *s) +{ + if (plotting && in_plot_style) + { + char *sty = plot_style_token (s); + if (sty != (char *) NULL) + { + in_plot_style = 0; + yylval.string = strsave (sty); + return STYLE; + } + } + + int end_found = 0; + if (strcmp ("break", s) == 0) + return BREAK; + else if (strcmp ("continue", s) == 0) + return CONTINUE; + else if (strcmp ("else", s) == 0) + { return ELSE; } + else if (strcmp ("elseif", s) == 0) + { return ELSEIF; } + else if (strcmp ("end", s) == 0) + { end_found = 1; yylval.ettype = simple_end; } + else if (strcmp ("endfor", s) == 0) + { end_found = 1; yylval.ettype = for_end; } + else if (strcmp ("endfunction", s) == 0) + { end_found = 1; yylval.ettype = function_end; } + else if (strcmp ("endif", s) == 0) + { end_found = 1; yylval.ettype = if_end; } + else if (strcmp ("endwhile", s) == 0) + { end_found = 1; yylval.ettype = while_end; } + else if (strcmp ("for", s) == 0) + { promptflag--; looping++; return FOR; } + else if (strcmp ("function", s) == 0) + { + if (defining_func) + { + error ("sorry, nested functions are a no-no..."); + jump_to_top_level (); + } + else + { + tmp_local_sym_tab = new symbol_table (); + curr_sym_tab = tmp_local_sym_tab; + defining_func = 1; + promptflag--; + beginning_of_function = 1; + help_buf[0] = '\0'; + return FCN; + } + } + else if (strcmp ("global", s) == 0) + return GLOBAL; + else if (strcmp ("gplot", s) == 0) + { plotting = 1; yylval.pttype = two_dee; return PLOT; } + else if (strcmp ("gsplot", s) == 0) + { plotting = 1; yylval.pttype = three_dee; return PLOT; } + else if (strcmp ("if", s) == 0) + { iffing++; promptflag--; return IF; } + else if (strcmp ("return", s) == 0) + return FUNC_RET; + else if (strcmp ("while", s) == 0) + { promptflag--; looping++; return WHILE; } + + if (end_found) + { + if (!defining_func && !looping) + promptflag++; + return END; + } + + return 0; +} + +static symbol_record * +lookup_identifier (char *name) +{ + symbol_record *gsr = global_sym_tab->lookup (name, 0, 0); + + if (curr_sym_tab == top_level_sym_tab && gsr != (symbol_record *) NULL) + return gsr; + + return curr_sym_tab->lookup (name, 1, 0); +} + +static void +grab_help_text (void) +{ + int max_len = HELP_BUF_LENGTH - 1; + + int in_comment = 1; + int len = 0; + int c; + + while ((c = yyinput ()) != EOF) + { + if (in_comment) + { + help_buf[len++] = c; + if (c == '\n') + in_comment = 0; + } + else + { + switch (c) + { + case '%': + case '#': + in_comment = 1; + case ' ': + case '\t': + break; + default: + goto done; + } + } + + if (len > max_len) + { + message ("grab_help_text", + "buffer overflow after caching %d characters", + max_len); + + goto done; + } + } + + done: + +// Make sure there's an end of line so yylex sees an end to the +// comment immediately. + + yyunput (c, yytext); + if (c != '\n') + yyunput ('\n', yytext); + + help_buf[len] = '\0'; +} + +static int +match_any (char c, char *s) +{ + char tmp; + while ((tmp = *s++) != '\0') + { + if (c == tmp) + return 1; + } + return 0; +} + +static int +looks_like_bin_op (int spc_prev, int spc_next) +{ + return ((spc_prev && spc_next) || ! (spc_prev || spc_next)); +} + +static int +next_char_is_space (void) +{ + int c = yyinput (); + yyunput (c, yytext); + return (c == ' ' || c == '\t'); +} + +static int +next_token_is_postfix_unary_op (int spc_prev, char *yytext) +{ + int un_op = 0; + + int c0 = yyinput (); + int c1 = yyinput (); + + yyunput (c1, yytext); + yyunput (c0, yytext); + + int transpose = (c0 == '.' && c1 == '\''); + int hermitian = (c0 == '\''); + + un_op = (transpose || (hermitian && ! spc_prev)); + + return un_op; +} + +static int +next_token_is_bin_op (int spc_prev, char *yytext) +{ + int bin_op = 0; + int spc_next = 0; + + int c0 = yyinput (); + int c1 = yyinput (); + + switch (c0) + { + case '+': case '-': case '/': + case ':': case '\\': case '^': + spc_next = (c1 == ' ' || c1 == '\t'); + break; + + case '&': + if (c1 == '&') + spc_next = next_char_is_space (); + else + spc_next = (c1 == ' ' || c1 == '\t'); + break; + + case '*': + if (c1 == '*') + spc_next = next_char_is_space (); + else + spc_next = (c1 == ' ' || c1 == '\t'); + break; + + case '|': + if (c1 == '|') + spc_next = next_char_is_space (); + else + spc_next = (c1 == ' ' || c1 == '\t'); + break; + + case '<': + if (c1 == '=' || c1 == '>') + spc_next = next_char_is_space (); + else + spc_next = (c1 == ' ' || c1 == '\t'); + break; + + case '>': + if (c1 == '=') + spc_next = next_char_is_space (); + else + spc_next = (c1 == ' ' || c1 == '\t'); + break; + + case '~': case '!': case '=': + if (c1 == '=') + spc_next = next_char_is_space (); + else + goto done; + break; + + case '.': + if (c1 == '*') + { + int c2 = yyinput (); + if (c2 == '*') + spc_next = next_char_is_space (); + else + spc_next = (c2 == ' ' || c2 == '\t'); + yyunput (c2, yytext); + } + else if (c1 == '/' || c1 == '\\' || c1 == '^') + spc_next = next_char_is_space (); + else + goto done; + break; + + default: + goto done; + } + + bin_op = looks_like_bin_op (spc_prev, spc_next); + + done: + yyunput (c1, yytext); + yyunput (c0, yytext); + + return bin_op; +} + +char * +strip_trailing_whitespace (char *s) +{ + char *retval = strsave (s); + + char *t = strchr (retval, ' '); + if (t != (char *) NULL) + *t = '\0'; + + t = strchr (retval, '\t'); + if (t != (char *) NULL) + *t = '\0'; + + return retval; +} + +void +check_for_garbage_after_fcn_def (void) +{ +// By making a newline be the next character to be read, we will force +// the parser to return after reading the function. Calling yyunput +// with EOF seems not to work... + + int in_comment = 0; + int lineno = input_line_number; + int c; + while ((c = yyinput ()) != EOF) + { + switch (c) + { + case ' ': + case '\t': + case ';': + case ',': + break; + case '\n': + if (in_comment) + in_comment = 0; + break; + case '%': + case '#': + in_comment = 1; + break; + default: + if (in_comment) + break; + else + { + warning ("ignoring trailing garbage after end of function\n\ + near line %d of file `%s.m'", lineno, curr_m_file_name); + + yyunput ('\n', yytext); + return; + } + } + } + yyunput ('\n', yytext); +} + +/* Maybe someday... + +"+=" return ADD_EQ; +"-=" return SUB_EQ; +"*=" return MUL_EQ; +"/=" return DIV_EQ; +"\\=" return LEFTDIV_EQ; +".+=" return ADD_EQ; +".-=" return SUB_EQ; +".*=" return EMUL_EQ; +"./=" return EDIV_EQ; +".\\=" return ELEFTDIV_EQ; + +*/
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/lpsolve.cc Sun Aug 08 01:13:40 1993 +0000 @@ -0,0 +1,56 @@ +// tc-lpsolve.cc -*- C++ -*- +/* + +Copyright (C) 1993 John W. Eaton + +This file is part of Octave. + +Octave is free software; you can redistribute it and/or modify it +under the terms of the GNU General Public License as published by the +Free Software Foundation; either version 2, or (at your option) any +later version. + +Octave is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +for more details. + +You should have received a copy of the GNU General Public License +along with Octave; see the file COPYING. If not, write to the Free +Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. + +*/ + +#ifdef __GNUG__ +#pragma implementation +#endif + +#include "LPsolve.h" + +#include "tree-const.h" +#include "error.h" + +#ifdef WITH_DLD +tree_constant * +builtin_lpsolve_2 (tree_constant *args, int nargin, int nargout) +{ + return lpsolve (args, nargin, nargout); +} +#endif + +tree_constant * +lpsolve (tree_constant *args, int nargin, int nargout) +{ +// Assumes that we have been given the correct number of arguments. + + tree_constant *retval = NULL_TREE_CONST; + message ("lpsolve", "sorry, not implemented yet"); + return retval; +} + +/* +;;; Local Variables: *** +;;; mode: C++ *** +;;; page-delimiter: "^/\\*" *** +;;; End: *** +*/
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/lsode.cc Sun Aug 08 01:13:40 1993 +0000 @@ -0,0 +1,141 @@ +// tc-lsode.cc -*- C++ -*- +/* + +Copyright (C) 1993 John W. Eaton + +This file is part of Octave. + +Octave is free software; you can redistribute it and/or modify it +under the terms of the GNU General Public License as published by the +Free Software Foundation; either version 2, or (at your option) any +later version. + +Octave is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +for more details. + +You should have received a copy of the GNU General Public License +along with Octave; see the file COPYING. If not, write to the Free +Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. + +*/ + +#ifdef __GNUG__ +#pragma implementation +#endif + +#include "ODE.h" + +#include "tree-const.h" +#include "variables.h" +#include "gripes.h" +#include "error.h" +#include "utils.h" + +// Global pointer for user defined function required by lsode. +static tree *lsode_fcn; + + +#ifdef WITH_DLD +tree_constant * +builtin_lsode_2 (tree_constant *args, int nargin, int nargout) +{ + return lsode (args, nargin, nargout); +} +#endif + +ColumnVector +lsode_user_function (const ColumnVector& x, double t) +{ + ColumnVector retval; + + int nstates = x.capacity (); + +// tree_constant name (lsode_fcn->name ()); + tree_constant *args = new tree_constant [3]; +// args[0] = name; + args[2] = tree_constant (t); + + if (nstates > 1) + { + Matrix m (nstates, 1); + for (int i = 0; i < nstates; i++) + m (i, 0) = x.elem (i); + tree_constant state (m); + args[1] = state; + } + else + { + double d = x.elem (0); + tree_constant state (d); + args[1] = state; + } + + if (lsode_fcn != NULL_TREE) + { + tree_constant *tmp = lsode_fcn->eval (args, 3, 1, 0); + delete [] args; + if (tmp != NULL_TREE_CONST && tmp[0].is_defined ()) + { + retval = tmp[0].to_vector (); + delete [] tmp; + } + else + { + delete [] tmp; + gripe_user_supplied_eval ("lsode"); + jump_to_top_level (); + } + } + + return retval; +} + +tree_constant * +lsode (tree_constant *args, int nargin, int nargout) +{ +// Assumes that we have been given the correct number of arguments. + + tree_constant *retval = NULL_TREE_CONST; + + lsode_fcn = is_valid_function (args[1], "lsode", 1); + if (lsode_fcn == NULL_TREE + || takes_correct_nargs (lsode_fcn, 3, "lsode", 1) != 1) + return retval; + + ColumnVector state = args[2].to_vector (); + ColumnVector out_times = args[3].to_vector (); + ColumnVector crit_times; + int crit_times_set = 0; + if (nargin > 4) + { + crit_times = args[4].to_vector (); + crit_times_set = 1; + } + + double tzero = out_times.elem (0); + int nsteps = out_times.capacity (); + + ODEFunc func (lsode_user_function); + ODE ode (state, tzero, func); + + int nstates = state.capacity (); + Matrix output (nsteps, nstates + 1); + + if (crit_times_set) + output = ode.integrate (out_times, crit_times); + else + output = ode.integrate (out_times); + + retval = new tree_constant [2]; + retval[0] = tree_constant (output); + return retval; +} + +/* +;;; Local Variables: *** +;;; mode: C++ *** +;;; page-delimiter: "^/\\*" *** +;;; End: *** +*/
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/lu.cc Sun Aug 08 01:13:40 1993 +0000 @@ -0,0 +1,154 @@ +// tc-lu.cc -*- C++ -*- +/* + +Copyright (C) 1993 John W. Eaton + +This file is part of Octave. + +Octave is free software; you can redistribute it and/or modify it +under the terms of the GNU General Public License as published by the +Free Software Foundation; either version 2, or (at your option) any +later version. + +Octave is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +for more details. + +You should have received a copy of the GNU General Public License +along with Octave; see the file COPYING. If not, write to the Free +Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. + +*/ + +#ifdef __GNUG__ +#pragma implementation +#endif + +#include "Matrix.h" + +#include "tree-const.h" +#include "user-prefs.h" +#include "gripes.h" + +#ifdef WITH_DLD +tree_constant * +builtin_lu_2 (tree_constant *args, int nargin, int nargout) +{ + return lu (args[1], nargout); +} +#endif + +tree_constant * +lu (tree_constant& a, int nargout) +{ + tree_constant *retval = new tree_constant [4]; + + tree_constant tmp = a.make_numeric ();; + + if (tmp.rows () == 0 || tmp.columns () == 0) + { + int flag = user_pref.propagate_empty_matrices; + if (flag != 0) + { + if (flag < 0) + gripe_empty_arg ("lu", 0); + Matrix m; + retval = new tree_constant [4]; + retval[0] = tree_constant (m); + retval[1] = tree_constant (m); + retval[2] = tree_constant (m); + return retval; + } + else + gripe_empty_arg ("lu", 1); + } + + switch (tmp.const_type ()) + { + case tree_constant_rep::matrix_constant: + { + Matrix m = tmp.matrix_value (); + if (m.rows () == m.columns ()) + { + LU fact (m); + switch (nargout) + { + case 1: + case 2: + { + Matrix P = fact.P (); + Matrix L = P.transpose () * fact.L (); + retval[0] = tree_constant (L); + retval[1] = tree_constant (fact.U ()); + } + break; + case 3: + default: + retval[0] = tree_constant (fact.L ()); + retval[1] = tree_constant (fact.U ()); + retval[2] = tree_constant (fact.P ()); + break; + } + } + else + gripe_square_matrix_required ("lu"); + } + break; + case tree_constant_rep::complex_matrix_constant: + { + ComplexMatrix m = tmp.complex_matrix_value (); + if (m.rows () == m.columns ()) + { + ComplexLU fact (m); + switch (nargout) + { + case 1: + case 2: + { + ComplexMatrix P = fact.P (); + ComplexMatrix L = P.transpose () * fact.L (); + retval[0] = tree_constant (L); + retval[1] = tree_constant (fact.U ()); + } + break; + case 3: + default: + retval[0] = tree_constant (fact.L ()); + retval[1] = tree_constant (fact.U ()); + retval[2] = tree_constant (fact.P ()); + break; + } + } + else + gripe_square_matrix_required ("lu"); + } + break; + case tree_constant_rep::scalar_constant: + { + double d = tmp.double_value (); + retval[0] = tree_constant (1.0); + retval[1] = tree_constant (d); + retval[2] = tree_constant (1.0); + } + break; + case tree_constant_rep::complex_scalar_constant: + { + Complex c = tmp.complex_value (); + retval[0] = tree_constant (1.0); + retval[1] = tree_constant (c); + retval[2] = tree_constant (1.0); + } + break; + default: + break; + } + return retval; +} + +/* +;;; Local Variables: *** +;;; mode: C++ *** +;;; page-delimiter: "^/\\*" *** +;;; End: *** +*/
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/mappers.cc Sun Aug 08 01:13:40 1993 +0000 @@ -0,0 +1,272 @@ +// mappers.cc -*- C++ -*- +/* + +Copyright (C) 1992, 1993 John W. Eaton + +This file is part of Octave. + +Octave is free software; you can redistribute it and/or modify it +under the terms of the GNU General Public License as published by the +Free Software Foundation; either version 2, or (at your option) any +later version. + +Octave is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +for more details. + +You should have received a copy of the GNU General Public License +along with Octave; see the file COPYING. If not, write to the Free +Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. + +*/ + +#ifdef __GNUG__ +#pragma implementation +#endif + +#include <float.h> + +#include "mappers.h" +#include "utils.h" + +#if defined (_AIX) && defined (__GNUG__) +#undef finite +#define finite(x) ((x) < DBL_MAX && (x) > -DBL_MAX) +#endif + +/* + * Double -> double mappers. + */ + +double +arg (double x) +{ + return 0.0; +} + +double +conj (double x) +{ + return x; +} + +double +fix (double x) +{ + int tmp; + tmp = (int) x; + return (double) tmp; +} + +double +imag (double x) +{ + return 0.0; +} + +double +real (double x) +{ + return x; +} + +double +round (double x) +{ + return D_NINT (x); +} + +double +signum (double x) +{ + double tmp = 0.0; + if (x < 0.0) + tmp = -1.0; + else if (x > 0.0) + tmp = 1.0; + return tmp; +} + +double +xisnan (double x) +{ +#if defined (HAVE_ISNAN) + return (double) isnan (x); +#else + return 0; +#endif +} + +double +xfinite (double x) +{ +#if defined (HAVE_FINITE) + return (double) finite (x); +#elif defined (HAVE_ISINF) && defined (HAVE_ISNAN) + return (double) (! isinf (x) && ! isnan (x)); +#else + return (double) (x > -DBL_MAX && x < DBL_MAX); +#endif +} + +double +xisinf (double x) +{ +#if defined (HAVE_ISINF) + return (double) isinf (x); +#elif defined (HAVE_FINITE) && defined (HAVE_ISNAN) + return (double) (! (finite (x) || isnan (x))); +#else + return (double) (x == DBL_MAX || x == -DBL_MAX); +#endif +} + +/* + * Complex -> double mappers. + */ + +double +xisnan (const Complex& x) +{ +#if defined (HAVE_ISNAN) + double rx = real (x); + double ix = imag (x); + return (double) (isnan (rx) || isnan (ix)); +#else + return 0; +#endif +} + +double +xfinite (const Complex& x) +{ + double rx = real (x); + double ix = imag (x); + return (double) (! ((int) xisinf (rx) || (int) xisinf (ix))); +} + +double +xisinf (const Complex& x) +{ + return (double) (! (int) xfinite (x)); +} + +/* + * Complex -> complex mappers. + */ + +Complex +acos (const Complex& x) +{ + static Complex i (0, 1); + Complex retval = -i * log (x + sqrt (x*x - 1.0)); + return retval; +} + +Complex +acosh (const Complex& x) +{ + Complex retval = log (x + sqrt (x*x - 1.0)); + return retval; +} + +Complex +asin (const Complex& x) +{ + static Complex i (0, 1); + Complex retval = -i * log (i*x + sqrt (1.0 - x*x)); + return retval; +} + +Complex +asinh (const Complex& x) +{ + Complex retval = log (x + sqrt (x*x + 1.0)); + return retval; +} + +Complex +atan (const Complex& x) +{ + static Complex i (0, 1); + Complex retval = i * log ((i + x) / (i - x)) / 2.0; + return retval; +} + +Complex +atanh (const Complex& x) +{ + static Complex i (0, 1); + Complex retval = log ((i + x) / (i - x)) / 2.0; + return retval; +} + +Complex +ceil (const Complex& x) +{ + int re = (int) ceil (real (x)); + int im = (int) ceil (imag (x)); + return Complex (re, im); +} + +Complex +fix (const Complex& x) +{ + int re = (int) real (x); + int im = (int) imag (x); + return Complex (re, im); +} + +Complex +floor (const Complex& x) +{ + int re = (int) floor (real (x)); + int im = (int) floor (imag (x)); + return Complex (re, im); +} + +#ifndef M_LOG10E +#define M_LOG10E 0.43429448190325182765 +#endif + +Complex +log10 (const Complex& x) +{ + return M_LOG10E * log (x); +} + +Complex +round (const Complex& x) +{ + double re = D_NINT (real (x)); + double im = D_NINT (imag (x)); + return Complex (re, im); +} + +Complex +signum (const Complex& x) +{ + return x / abs (x); +} + +Complex +tan (const Complex& x) +{ + Complex retval = sin (x) / cos (x); + return retval; +} + +Complex +tanh (const Complex& x) +{ + Complex retval = sinh (x) / cosh (x); + return retval; +} + +/* +;;; Local Variables: *** +;;; mode: C++ *** +;;; page-delimiter: "^/\\*" *** +;;; End: *** +*/
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/mappers.h Sun Aug 08 01:13:40 1993 +0000 @@ -0,0 +1,72 @@ +// mappers.h -*- C++ -*- +/* + +Copyright (C) 1992, 1993 John W. Eaton + +This file is part of Octave. + +Octave is free software; you can redistribute it and/or modify it +under the terms of the GNU General Public License as published by the +Free Software Foundation; either version 2, or (at your option) any +later version. + +Octave is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +for more details. + +You should have received a copy of the GNU General Public License +along with Octave; see the file COPYING. If not, write to the Free +Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. + +*/ + +#if !defined (_mappers_h) +#define _mappers_h 1 + +#ifdef __GNUG__ +#pragma interface +#endif + +#include <Complex.h> + +#include "missing-math.h" + +extern double arg (double x); +extern double conj (double x); +extern double fix (double x); +extern double imag (double x); +extern double real (double x); +extern double round (double x); +extern double signum (double x); +extern double xfinite (double x); +extern double xisinf (double x); +extern double xisnan (double x); + +extern double xfinite (const Complex& x); +extern double xisinf (const Complex& x); +extern double xisnan (const Complex& x); + +extern Complex acos (const Complex& x); +extern Complex acosh (const Complex& x); +extern Complex asin (const Complex& x); +extern Complex asinh (const Complex& x); +extern Complex atan (const Complex& x); +extern Complex atanh (const Complex& x); +extern Complex ceil (const Complex& x); +extern Complex fix (const Complex& x); +extern Complex floor (const Complex& x); +extern Complex log10 (const Complex& x); +extern Complex round (const Complex& x); +extern Complex signum (const Complex& x); +extern Complex tan (const Complex& x); +extern Complex tanh (const Complex& x); + +#endif + +/* +;;; Local Variables: *** +;;; mode: C++ *** +;;; page-delimiter: "^/\\*" *** +;;; End: *** +*/
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/npsol.cc Sun Aug 08 01:13:40 1993 +0000 @@ -0,0 +1,425 @@ +// tc-npsol.cc -*- C++ -*- +/* + +Copyright (C) 1993 John W. Eaton + +This file is part of Octave. + +Octave is free software; you can redistribute it and/or modify it +under the terms of the GNU General Public License as published by the +Free Software Foundation; either version 2, or (at your option) any +later version. + +Octave is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +for more details. + +You should have received a copy of the GNU General Public License +along with Octave; see the file COPYING. If not, write to the Free +Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. + +*/ + +#ifdef __GNUG__ +#pragma implementation +#endif + +#ifndef NPSOL_MISSING + +#include "NPSOL.h" + +#include "tree-const.h" +#include "variables.h" +#include "gripes.h" +#include "error.h" +#include "utils.h" + +// Global pointers for user defined functions required by npsol. +static tree *npsol_objective; +static tree *npsol_constraints; + +#ifdef WITH_DLD +tree_constant * +builtin_npsol_2 (tree_constant *args, int nargin, int nargout) +{ + return npsol (args, nargin, nargout); +} +#endif + +double +npsol_objective_function (ColumnVector& x) +{ + int n = x.capacity (); + + tree_constant decision_vars; + if (n > 1) + { + Matrix m (n, 1); + for (int i = 0; i < n; i++) + m (i, 0) = x.elem (i); + decision_vars = tree_constant (m); + } + else + { + double d = x.elem (0); + decision_vars = tree_constant (d); + } + +// tree_constant name = tree_constant (npsol_objective->name ()); + tree_constant *args = new tree_constant [2]; +// args[0] = name; + args[1] = decision_vars; + + tree_constant objective_value; + if (npsol_objective != NULL_TREE) + { + tree_constant *tmp = npsol_objective->eval (args, 2, 1, 0); + delete [] args; + if (tmp != NULL_TREE_CONST && tmp[0].is_defined ()) + { + objective_value = tmp[0]; + delete [] tmp; + } + else + { + delete [] tmp; + message ("npsol", "error evaluating objective function"); + jump_to_top_level (); + } + } + + static double retval; + retval = 0.0; + + switch (objective_value.const_type ()) + { + case tree_constant_rep::matrix_constant: + { + Matrix m = objective_value.matrix_value (); + if (m.rows () == 1 && m.columns () == 1) + retval = m.elem (0, 0); + else + gripe_user_returned_invalid ("npsol_objective"); + } + break; + case tree_constant_rep::scalar_constant: + retval = objective_value.double_value (); + break; + default: + gripe_user_returned_invalid ("npsol_objective"); + break; + } + + return retval; +} + +ColumnVector +npsol_constraint_function (ColumnVector& x) +{ + ColumnVector retval; + + int n = x.capacity (); + + tree_constant decision_vars; + if (n > 1) + { + Matrix m (n, 1); + for (int i = 0; i < n; i++) + m (i, 0) = x.elem (i); + decision_vars = tree_constant (m); + } + else + { + double d = x.elem (0); + decision_vars = tree_constant (d); + } + +// tree_constant name = tree_constant (npsol_constraints->name ()); + tree_constant *args = new tree_constant [2]; +// args[0] = name; + args[1] = decision_vars; + + if (npsol_constraints != NULL_TREE) + { + tree_constant *tmp = npsol_constraints->eval (args, 2, 1, 0); + delete [] args; + if (tmp != NULL_TREE_CONST && tmp[0].is_defined ()) + { + retval = tmp[0].to_vector (); + delete [] tmp; + } + else + { + delete [] tmp; + message ("npsol", "error evaluating constraints"); + jump_to_top_level (); + } + } + + return retval; +} + +int +linear_constraints_ok (const ColumnVector& x, const ColumnVector& llb, + const Matrix& c, const ColumnVector& lub, + char *warn_for, int warn) +{ + int x_len = x.capacity (); + int llb_len = llb.capacity (); + int lub_len = lub.capacity (); + int c_rows = c.rows (); + int c_cols = c.columns (); + int ok = x_len == c_cols && llb_len == lub_len && llb_len == c_rows; + + if (! ok && warn) + message (warn_for, "linear constraints have inconsistent dimensions"); + + return ok; +} + +int +nonlinear_constraints_ok (const ColumnVector& x, const ColumnVector& nllb, + nonlinear_fcn g, const ColumnVector& nlub, + char *warn_for, int warn) +{ + int nllb_len = nllb.capacity (); + int nlub_len = nlub.capacity (); + ColumnVector c = (*g) (x); + int c_len = c.capacity (); + int ok = nllb_len == nlub_len && nllb_len == c_len; + + if (! ok && warn) + message (warn_for, "nonlinear constraints have inconsistent dimensions"); + + return ok; +} + +tree_constant * +npsol (tree_constant *args, int nargin, int nargout) +{ +/* + +Handle all of the following: + + 1. npsol (x, phi) + 2. npsol (x, phi, lb, ub) + 3. npsol (x, phi, lb, ub, llb, c, lub) + 4. npsol (x, phi, lb, ub, llb, c, lub, nllb, g, nlub) + 5. npsol (x, phi, lb, ub, nllb, g, nlub) + 6. npsol (x, phi, llb, c, lub, nllb, g, nlub) + 7. npsol (x, phi, llb, c, lub) + 8. npsol (x, phi, nllb, g, nlub) + +*/ + +// Assumes that we have been given the correct number of arguments. + + tree_constant *retval = NULL_TREE_CONST; + + ColumnVector x = args[1].to_vector (); + + if (x.capacity () == 0) + { + message ("npsol", "expecting vector as first argument"); + return retval; + } + + npsol_objective = is_valid_function (args[2], "npsol", 1); + if (npsol_objective == NULL_TREE + || takes_correct_nargs (npsol_objective, 2, "npsol", 1) != 1) + return retval; + + Objective func (npsol_objective_function); + + ColumnVector soln; + + Bounds bounds; + if (nargin == 5 || nargin == 8 || nargin == 11) + { + ColumnVector lb = args[3].to_vector (); + ColumnVector ub = args[4].to_vector (); + + int lb_len = lb.capacity (); + int ub_len = ub.capacity (); + if (lb_len != ub_len || lb_len != x.capacity ()) + { + message ("npsol", "lower and upper bounds and decision variable\n\ + vector must all have the same number of elements"); + return retval; + } + + bounds.resize (lb_len); + bounds.set_lower_bounds (lb); + bounds.set_upper_bounds (ub); + } + + double objf; + ColumnVector lambda; + int inform; + + if (nargin == 3) + { + // 1. npsol (x, phi) + + NPSOL nlp (x, func); + soln = nlp.minimize (objf, inform, lambda); + + goto solved; + } + + if (nargin == 5) + { + // 2. npsol (x, phi, lb, ub) + + NPSOL nlp (x, func, bounds); + soln = nlp.minimize (objf, inform, lambda); + + goto solved; + } + + npsol_constraints = NULL_TREE; + if (nargin == 6 || nargin == 8 || nargin == 9 || nargin == 11) + npsol_constraints = is_valid_function (args[nargin-2], "npsol", 0); + + if (nargin == 8 || nargin == 6) + { + if (npsol_constraints == NULL_TREE) + { + ColumnVector lub = args[nargin-1].to_vector (); + Matrix c = args[nargin-2].to_matrix (); + ColumnVector llb = args[nargin-3].to_vector (); + + LinConst linear_constraints (llb, c, lub); + + if (! linear_constraints_ok (x, llb, c, lub, "npsol", 1)) + return retval; + + if (nargin == 6) + { + // 7. npsol (x, phi, llb, c, lub) + + NPSOL nlp (x, func, linear_constraints); + soln = nlp.minimize (objf, inform, lambda); + } + else + { + // 3. npsol (x, phi, lb, ub, llb, c, lub) + + NPSOL nlp (x, func, bounds, linear_constraints); + soln = nlp.minimize (objf, inform, lambda); + } + goto solved; + } + else + { + if (takes_correct_nargs (npsol_constraints, 2, "npsol", 1)) + { + ColumnVector nlub = args[nargin-1].to_vector (); + ColumnVector nllb = args[nargin-3].to_vector (); + + NLFunc const_func (npsol_constraint_function); + + if (! nonlinear_constraints_ok + (x, nllb, npsol_constraint_function, nlub, "npsol", 1)) + return retval; + + NLConst nonlinear_constraints (nllb, const_func, nlub); + + if (nargin == 6) + { + // 8. npsol (x, phi, nllb, g, nlub) + + NPSOL nlp (x, func, nonlinear_constraints); + soln = nlp.minimize (objf, inform, lambda); + } + else + { + // 5. npsol (x, phi, lb, ub, nllb, g, nlub) + + NPSOL nlp (x, func, bounds, nonlinear_constraints); + soln = nlp.minimize (objf, inform, lambda); + } + goto solved; + } + } + } + + if (nargin == 9 || nargin == 11) + { + if (npsol_constraints == NULL_TREE) + { + // Produce error message. + is_valid_function (args[nargin-2], "npsol", 1); + } + else + { + if (takes_correct_nargs (npsol_constraints, 2, "npsol", 1)) + { + ColumnVector nlub = args[nargin-1].to_vector (); + ColumnVector nllb = args[nargin-3].to_vector (); + + NLFunc const_func (npsol_constraint_function); + + if (! nonlinear_constraints_ok + (x, nllb, npsol_constraint_function, nlub, "npsol", 1)) + return retval; + + NLConst nonlinear_constraints (nllb, const_func, nlub); + + ColumnVector lub = args[nargin-4].to_vector (); + Matrix c = args[nargin-5].to_matrix (); + ColumnVector llb = args[nargin-6].to_vector (); + + if (! linear_constraints_ok (x, llb, c, lub, "npsol", 1)) + return retval; + + LinConst linear_constraints (llb, c, lub); + + if (nargin == 9) + { + // 6. npsol (x, phi, llb, c, lub, nllb, g, nlub) + + NPSOL nlp (x, func, linear_constraints, + nonlinear_constraints); + + soln = nlp.minimize (objf, inform, lambda); + } + else + { + // 4. npsol (x, phi, lb, ub, llb, c, lub, nllb, g, nlub) + + NPSOL nlp (x, func, bounds, linear_constraints, + nonlinear_constraints); + + soln = nlp.minimize (objf, inform, lambda); + } + goto solved; + } + } + } + + return retval; + + solved: + + retval = new tree_constant [nargout+1]; + retval[0] = tree_constant (soln, 1); + if (nargout > 1) + retval[1] = tree_constant (objf); + if (nargout > 2) + retval[2] = tree_constant ((double) inform); + if (nargout > 3) + retval[3] = tree_constant (lambda); + + return retval; +} + +#endif + +/* +;;; Local Variables: *** +;;; mode: C++ *** +;;; page-delimiter: "^/\\*" *** +;;; End: *** +*/
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/oct-hist.cc Sun Aug 08 01:13:40 1993 +0000 @@ -0,0 +1,521 @@ +// octave-hist.cc -*- C++ -*- +/* + +Copyright (C) 1992, 1993 John W. Eaton + +This file is part of Octave. + +Octave is free software; you can redistribute it and/or modify it +under the terms of the GNU General Public License as published by the +Free Software Foundation; either version 2, or (at your option) any +later version. + +Octave is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +for more details. + +You should have received a copy of the GNU General Public License +along with Octave; see the file COPYING. If not, write to the Free +Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. + +The functions listed below were adapted from similar functions from +GNU Bash, the Bourne Again SHell, copyright (C) 1987, 1989, 1991 Free +Software Foundation, Inc. + + do_history edit_history_readline + do_edit_history edit_history_add_hist + +*/ + +#ifdef __GNUG__ +#pragma implementation +#endif + +#include <sys/types.h> +#ifdef HAVE_UNISTD_H +#include <unistd.h> +#endif +#include <fcntl.h> +#include <stdlib.h> +#include <stdio.h> +#include <string.h> +#include <signal.h> +#include <fstream.h> +#include <strstream.h> + +#include "statdefs.h" +#include "utils.h" +#include "error.h" +#include "input.h" +#include "octave.h" +#include "unwind-prot.h" +#include "octave-hist.h" +#include "sighandlers.h" + +extern "C" +{ +#include <readline/history.h> +} + +// Nonzero means we are saving history lines. +int saving_history = 1; + +// The number of lines to save in the history file. +static int octave_hist_size = 1024; + +// The name of the history file. +static char *octave_hist_file; + +// The number of hisory lines we read from the history file. +static int history_lines_in_file = 0; + +// The number of history lines we've saved so far. +static int history_lines_this_session = 0; + +/* + * Get some default values, possibly reading them from the + * environment. + */ +static int +default_history_size (void) +{ + int size = 1024; + char *env_size = getenv ("OCTAVE_HISTSIZE"); + if (env_size != (char *) NULL) + { + int val; + if (sscanf (env_size, "%d", &val) == 1) + size = val > 0 ? val : 0; + } + return size; +} + +static char * +default_history_file (void) +{ + char *file = (char *) NULL;; + + char *env_file = getenv ("OCTAVE_HISTFILE"); + if (env_file != (char *) NULL) + { + fstream f (env_file, (ios::in | ios::out)); + if (f != 0) + { + file = strsave (env_file); + f.close (); + } + } + + if (file == (char *) NULL) + { + if (home_directory != NULL) + file = strconcat (home_directory, "/.octave_hist"); + } + + return file; +} + +/* + * Prime the history list. + */ +void +initialize_history (void) +{ + octave_hist_file = default_history_file (); + octave_hist_size = default_history_size (); + + read_history (octave_hist_file); + using_history (); + history_lines_in_file = where_history (); +} + +void +clean_up_history (void) +{ + stifle_history (octave_hist_size); + write_history (octave_hist_file); +} + +void +maybe_save_history (char *s) +{ + if (saving_history) + { + add_history (s); + history_lines_this_session++; + } +} + +/* + * Display, save, or load history. Stolen and modified from bash. + * + * Arg of -w FILENAME means write file, arg of -r FILENAME + * means read file, arg of -q means don't number lines. Arg of N + * means only display that many items. + */ +void +do_history (int argc, char **argv) +{ + HIST_ENTRY **hlist; + + int numbered_output = 1; + + while (--argc > 0) + { + argv++; + + if (*argv[0] == '-' && strlen (*argv) == 2 + && ((*argv)[1] == 'r' || (*argv)[1] == 'w' + || (*argv)[1] == 'a' || (*argv)[1] == 'n')) + { + char *file; + int result = 0; + + if (argc > 1) + file = *(argv+1); + else + file = octave_hist_file; + + switch ((*argv)[1]) + { + case 'a': // Append `new' lines to file. + { + if (history_lines_this_session) + { + if (history_lines_this_session < where_history ()) + { +// If the filename was supplied, then create it if it doesn't already +// exist. + if (file) + { + struct stat buf; + + if (stat (file, &buf) == -1) + { + int tem; + + tem = open (file, O_CREAT, 0666); + close (tem); + } + } + + result = + append_history (history_lines_this_session, file); + history_lines_in_file += history_lines_this_session; + history_lines_this_session = 0; + } + } + } + break; + case 'w': // Write entire history. + result = write_history (file); + break; + case 'r': // Read entire file. + result = read_history (file); + break; + case 'n': // Read `new' history from file. +// Read all of the lines in the file that we haven't already read. + using_history (); + result = read_history_range (file, history_lines_in_file, -1); + using_history (); + history_lines_in_file = where_history (); + break; + } + return; + } + else if (strcmp (*argv, "-q") == 0) + numbered_output = 0; + else if (strcmp (*argv, "--") == 0) + { + argc--; + argv++; + break; + } + else + break; + } + + int limited = 0; + int limit = 0; + + if (argc > 0) + { + limited = 1; + if (sscanf (*argv, "%d", &limit) != 1) + { + if (*argv[0] == '-') + message ("history", "unrecognized option `%s'", *argv); + else + message ("history", "bad non-numeric arg `%s'", *argv); + return; + } + } + + hlist = history_list (); + + if (hlist) + { + for (int i = 0; hlist[i] != (HIST_ENTRY *) NULL; i++) + ; // Do nothing. + + if (limit < 0) + limit = -limit; + + if (!limited) + i = 0; + else + if ((i -= limit) < 0) + i = 0; + + while (hlist[i]) + { +// QUIT; // in bash: (interrupt_state) throw_to_top_level (); + + if (numbered_output) + cerr.form ("%5d%c", i + history_base, hlist[i]->data ? '*' : ' '); + cerr << hlist[i]->line << "\n"; + i++; + } + } +} + +/* + * Read the edited history lines from STREAM and return them + * one at a time. This can read unlimited length lines. The + * caller should free the storage. + */ +static char * +edit_history_readline (fstream& stream) +{ + char c; + int line_len = 128; + int lindex = 0; + char *line = new char [line_len]; + line[0] = '\0'; + + while (stream.get (c)) + { + if (lindex + 2 >= line_len) + { + char *tmp_line = new char [line_len += 128]; + strcpy (tmp_line, line); + delete [] line; + line = tmp_line; + } + + if (c == '\n') + { + line[lindex++] = '\n'; + line[lindex++] = '\0'; + return line; + } + else + line[lindex++] = c; + } + + if (! lindex) + { + delete [] line; + return (char *) NULL; + } + + if (lindex + 2 >= line_len) + { + char *tmp_line = new char [lindex+3]; + strcpy (tmp_line, line); + delete [] line; + line = tmp_line; + } + +// Finish with newline if none in file. + + line[lindex++] = '\n'; + line[lindex++] = '\0'; + return line; +} + +static void +edit_history_add_hist (char *line) +{ + if (line != (char *) NULL) + { + int len = strlen (line); + if (len > 0 && line[len-1] == '\n') + line[len-1] = '\0'; + + if (line[0] != '\0') + add_history (line); + } +} + +#define histline(i) (hlist[(i)]->line) + +#define EDIT_COMMAND "${EDITOR:-vi}" + +void +do_edit_history (int argc, char **argv) +{ + HIST_ENTRY **hlist; + + hlist = history_list (); + + int hist_count = 0; + + while (hlist[hist_count++] != (HIST_ENTRY *) NULL) + ; // Find the number of items in the history list. + +// The current command line is already part of the history list by the +// time we get to this point. Delete it from the list. + + hist_count -= 2; + remove_history (hist_count); + hist_count--; + +// If no numbers have been specified, the default is to edit the last +// command in the history list. + + int hist_end = hist_count; + int hist_beg = hist_count; + int reverse = 0; + +// Process options + + int usage_error = 0; + if (argc == 3) + { + argv++; + if (sscanf (*argv++, "%d", &hist_beg) != 1 + || sscanf (*argv, "%d", &hist_end) != 1) + usage_error = 1; + else + { + hist_beg--; + hist_end--; + } + } + else if (argc == 2) + { + argv++; + if (sscanf (*argv++, "%d", &hist_beg) != 1) + usage_error = 1; + else + { + hist_beg--; + hist_end = hist_beg; + } + } + + if (hist_beg < 0 || hist_end < 0 || hist_beg > hist_count + || hist_end > hist_count) + { + error ("history specification out of range"); + return; + } + + if (usage_error) + { + usage ("edit_history [first] [last]"); + return; + } + + if (hist_end < hist_beg) + { + int t = hist_end; + hist_end = hist_beg; + hist_beg = t; + reverse = 1; + } + + char *name = tmpnam ((char *) NULL); + + fstream file (name, ios::out); + if (! file) + { + error ("edit_history: couldn't open temporary file `%s'", name); + return; + } + + if (reverse) + { + for (int i = hist_end; i >= hist_beg; i--) + file << histline (i) << "\n"; + } + else + { + for (int i = hist_beg; i <= hist_end; i++) + file << histline (i) << "\n"; + } + + file.close (); + +// Call up our favorite editor on the file of commands. + + ostrstream buf; + buf << EDIT_COMMAND << " " << name << ends; + char *cmd = buf.str (); + +// Ignore interrupts while we are off editing commands. Should we +// maybe avoid using system()? There still seems to be a problem with +// properly waiting for emacsclient. + + volatile sig_handler *saved_sigint_handler = signal (SIGINT, SIG_IGN); + system (cmd); + signal (SIGINT, saved_sigint_handler); + +// Write the commands to the history file since parse_and_execute +// disables command line history while it executes. + + file.open (name, ios::in); + + char *line; + while ((line = edit_history_readline (file)) != NULL) + { + +// Skip blank lines + + if (line[0] == '\n') + { + delete [] line; + continue; + } + + edit_history_add_hist (line); + } + + file.close (); + +// Turn on command echo, so the output from this will make better sense. + + begin_unwind_frame ("do_edit_history"); + unwind_protect_int (echo_input); + echo_input = 1; + + parse_and_execute (name, 1); + + run_unwind_frame ("do_edit_history"); + +// Delete the temporary file. Should probably be done with an +// unwind_protect. + + unlink (name); +} + +int +current_history_number (void) +{ + using_history (); + + if (octave_hist_size > 0) + return history_base + where_history (); + else + return -1; + +} + +/* +;;; Local Variables: *** +;;; mode: C++ *** +;;; page-delimiter: "^/\\*" *** +;;; End: *** +*/
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/oct-hist.h Sun Aug 08 01:13:40 1993 +0000 @@ -0,0 +1,48 @@ +// octave-hist.h -*- C++ -*- +/* + +Copyright (C) 1992, 1993 John W. Eaton + +This file is part of Octave. + +Octave is free software; you can redistribute it and/or modify it +under the terms of the GNU General Public License as published by the +Free Software Foundation; either version 2, or (at your option) any +later version. + +Octave is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +for more details. + +You should have received a copy of the GNU General Public License +along with Octave; see the file COPYING. If not, write to the Free +Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. + +*/ + +#if !defined (_octave_hist_h) +#define _octave_hist_h 1 + +#ifdef __GNUG__ +#pragma interface +#endif + +extern void initialize_history (void); +extern void clean_up_history (void); +extern void maybe_save_history (char*); +extern void do_history (int, char**); +extern void do_edit_history (int, char**); +extern int current_history_number (void); + +// Nonzero means we are saving history lines. +extern int saving_history; + +#endif + +/* +;;; Local Variables: *** +;;; mode: C++ *** +;;; page-delimiter: "^/\\*" *** +;;; End: *** +*/
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/octave.cc Sun Aug 08 01:13:40 1993 +0000 @@ -0,0 +1,469 @@ +// octave.cc -*- C++ -*- +/* + +Copyright (C) 1992, 1993 John W. Eaton + +This file is part of Octave. + +Octave is free software; you can redistribute it and/or modify it +under the terms of the GNU General Public License as published by the +Free Software Foundation; either version 2, or (at your option) any +later version. + +Octave is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +for more details. + +You should have received a copy of the GNU General Public License +along with Octave; see the file COPYING. If not, write to the Free +Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. + +*/ + +// Born February 20, 1992. + +#ifdef __GNUG__ +#pragma implementation +#endif + +#include <sys/types.h> +#include <time.h> +#include <pwd.h> +#include <setjmp.h> +#include <stdlib.h> +#include <string.h> +#include <signal.h> +#include <assert.h> +#include <iostream.h> +#include <fstream.h> +#include <GetOpt.h> + +#include "sighandlers.h" +#include "variables.h" +#include "error.h" +#include "tree-const.h" +#include "symtab.h" +#include "utils.h" +#include "builtins.h" +#include "input.h" +#include "pager.h" +#include "lex.h" +#include "octave.h" +#include "parse.h" +#include "unwind-prot.h" +#include "octave-hist.h" +#include "version.h" +#include "file-io.h" +#include "sysdep.h" + +// Signal handler return type. +#ifndef RETSIGTYPE +#define RETSIGTYPE void +#endif +#if 0 +#ifndef BADSIG +#define BADSIG (RETSIGTYPE (*)())-1 +#endif +#endif + +#ifdef sun +extern "C" { int on_exit (); } +#define atexit on_exit +#endif + +// argv[0] for this program. +char *raw_prog_name = (char *) NULL; + +// Cleaned-up name of this program, not including path information. +char *prog_name = (char *) NULL; + +// Login name for user running this program. +char *user_name = (char *) NULL; + +// Name of the host we are running on. +char *host_name = (char *) NULL; + +// User's home directory. +char *home_directory = (char *) NULL; + +// Guess what? +char *the_current_working_directory = (char *) NULL; + +// Load path specified on command line. +char *load_path = (char *) NULL; + +// If nonzero, don't do fancy line editing. +int no_line_editing = 0; + +// Command number, counting from the beginning of this session. +int current_command_number = 1; + +// Nonzero means we are exiting via the builtin exit or quit functions. +int quitting_gracefully = 0; + +// Current command to execute. +tree *global_command = (tree *) NULL; + +// Top level context (?) +jmp_buf toplevel; + +// Nonzero means we read ~/.octaverc and ./.octaverc. +static int read_init_files = 1; + +// Nonzero means we don\'t print the usual startup message. +static int inhibit_startup_message = 0; + +// Usage message +static const char *usage_string = "octave [-?dfhiqvx] [-p path] [file]"; + +// This is here so that it\'s more likely that the usage message and +// the real set of options will agree. +static const char *getopt_option_string = "?dfhip:qvx"; + +/* + * Initialize some global variables for later use. + */ +static void +initialize_globals (char *name) +{ + struct passwd *entry = getpwuid (getuid ()); + if (entry) + user_name = strsave (entry->pw_name); + else + user_name = strsave ("I have no name!"); + endpwent (); + + char hostname[256]; + if (gethostname (hostname, 255) < 0) + host_name = strsave ("I have no host!"); + else + host_name = strsave (hostname); + + char *hd = getenv ("HOME"); + if (hd == (char *) NULL) + home_directory = strsave ("I have no home~!"); + else + home_directory = strsave (hd); + + raw_prog_name = strsave (name); + prog_name = strsave ("octave"); + + load_path = default_path (); +} + +void +parse_and_execute (FILE *f, int print) +{ + begin_unwind_frame ("parse_and_execute"); + + YY_BUFFER_STATE old_buf = current_buffer (); + YY_BUFFER_STATE new_buf = create_buffer (f); + + add_unwind_protect (restore_input_buffer, (void *) old_buf); + add_unwind_protect (delete_input_buffer, (void *) new_buf); + + switch_to_buffer (new_buf); + + unwind_protect_int (echo_input); + unwind_protect_int (using_readline); + unwind_protect_int (saving_history); + + echo_input = 0; + using_readline = 0; + saving_history = 0; + + unwind_protect_ptr (curr_sym_tab); + + int retval; + do + { + retval = yyparse (); + if (retval == 0 && global_command != NULL_TREE) + { + global_command->eval (print); + delete global_command; + } + } + while (retval == 0); + + run_unwind_frame ("parse_and_execute"); +} + +void +parse_and_execute (char *s, int print) +{ + begin_unwind_frame ("parse_and_execute_2"); + + unwind_protect_int (reading_script_file); + + reading_script_file = 1; + + FILE *f = get_input_from_file (s, 0); + if (f != (FILE *) NULL) + { + unwind_protect_int (input_line_number); + unwind_protect_int (current_input_column); + unwind_protect_int (echo_input); + + input_line_number = 0; + current_input_column = 0; + echo_input = 0; + + parse_and_execute (f, print); + } + + run_unwind_frame ("parse_and_execute_2"); +} + +/* + * Initialize by reading startup files. + */ +static void +execute_startup_files (void) +{ +// Execute commands from the site-wide configuration file. + + char *sd = get_site_defaults (); + + parse_and_execute (sd, 0); + +// Try to execute commands from $HOME/.octaverc and ./.octaverc. + + if (home_directory != NULL) + { + char *rc = strconcat (home_directory, "/.octaverc"); + + parse_and_execute (rc, 0); + + delete [] rc; + } + + parse_and_execute ("./.octaverc", 0); +} + +/* + * Usage message with extra help. + */ +static void +verbose_usage (void) +{ + cout << "\n" + << " Octave, version " << version_string + << ". Copyright (C) 1992, 1993, John W. Eaton.\n" + << " This is free software with ABSOLUTELY NO WARRANTY.\n" + << "\n" + << " " << usage_string + << "\n" + << " d : enter parser debugging mode\n" + << " f : don't read ~/.octaverc or .octaverc at startup\n" + << " h|? : print short help message and exit\n" + << " i : force interactive behavior\n" + << " q : don't print message at startup\n" + << " x : echo commands as they are executed\n" + << "\n" + << " file : execute commands from named file\n" + << "\n"; + + exit (1); +} + +/* + * Terse usage messsage. + */ +static void +usage (void) +{ + usage (usage_string); + exit (1); +} + +/* + * Fix up things before exiting. + */ +volatile void +clean_up_and_exit (int retval) +{ + raw_mode (0); + clean_up_history (); + close_plot_stream (); + close_files (); + + if (!quitting_gracefully && (interactive || forced_interactive)) + cout << "\n"; + + if (retval == EOF) + retval = 0; + + exit (retval); +} + +static void +print_version_and_exit (void) +{ + cout << "octave, version " << version_string << "\n"; + exit (0); +} + +/* + * You guessed it. + */ +int +main (int argc, char **argv) +{ +// Allow for system dependent initialization. See sysdep.cc for more +// details. + sysdep_init (); + +// Do this first, since some command line arguments may override the +// defaults. + initialize_globals (argv[0]); + +// If the + GetOpt getopt (argc, argv, getopt_option_string); + int option_char; + + while ((option_char = getopt ()) != EOF) + { + switch (option_char) + { + case 'd': + yydebug++; + break; + case 'f': + read_init_files = 0; + break; + case 'h': + case '?': + verbose_usage (); + break; + case 'i': + forced_interactive = 1; + break; + case 'p': + if (getopt.optarg != (char *) NULL) + load_path = strsave (getopt.optarg); + break; + case 'q': + inhibit_startup_message = 1; + break; + case 'x': + echo_input = 1; + break; + case 'v': + print_version_and_exit (); + break; + default: + usage (); + break; + } + } + + if (! inhibit_startup_message) + { + cout << "Octave, version " << version_string + << ". Copyright (C) 1992, 1993, John W. Eaton.\n" + << "This is free software with ABSOLUTELY NO WARRANTY.\n" + << "For details, type `warranty'.\n" + << "\n"; + } + +// Make sure we clean up when we exit. + atexit (cleanup_tmp_files); + + initialize_history (); + + initialize_file_io (); + + global_sym_tab = new symbol_table (); + curr_sym_tab = global_sym_tab; + + install_builtins (); + + top_level_sym_tab = new symbol_table (); + curr_sym_tab = top_level_sym_tab; + + if (read_init_files) + { + saving_history = 0; + execute_startup_files (); + saving_history = 1; + } + + initialize_readline (); + + initialize_pager (); + +// Avoid counting commands executed from startup files. + current_command_number = 1; + +// If there is an extra argument, see if it names a file to read. + + if (getopt.optind != argc) + { + FILE *infile = get_input_from_file (argv[getopt.optind]); + if (infile == (FILE *) NULL) + clean_up_and_exit (1); + else + switch_to_buffer (create_buffer (infile)); + } + else + { +// Is input coming from a terminal? If so, we are probably +// interactive. + + switch_to_buffer (create_buffer (get_input_from_stdin ())); + + interactive = (isatty (fileno (stdin)) && isatty (fileno (stdout))); + } + +// Force input to be echoed if not really interactive, but the user +// has forced interactive behavior. + + if (!interactive && forced_interactive) + echo_input = 1; + + if (! (interactive || forced_interactive)) + using_readline = 0; + + install_signal_handlers (); + +// Allow the user to interrupt us without exiting. + + volatile sig_handler *saved_sigint_handler = signal (SIGINT, SIG_IGN); + + if (setjmp (toplevel) != 0) + { + raw_mode (0); + cout << "\n"; + } + + can_interrupt = 1; + + signal (SIGINT, saved_sigint_handler); + +// The big loop. + + int retval; + do + { + reset_parser (); + retval = yyparse (); + if (retval == 0 && global_command != NULL_TREE) + { + global_command->eval (1); + delete global_command; + current_command_number++; + } + } + while (retval == 0); + + clean_up_and_exit (retval); +} + +/* +;;; Local Variables: *** +;;; mode: C++ *** +;;; page-delimiter: "^/\\*" *** +;;; End: *** +*/
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/pager.cc Sun Aug 08 01:13:40 1993 +0000 @@ -0,0 +1,150 @@ +// pager.cc -*- C++ -*- +/* + +Copyright (C) 1992, 1993 John W. Eaton + +This file is part of Octave. + +Octave is free software; you can redistribute it and/or modify it +under the terms of the GNU General Public License as published by the +Free Software Foundation; either version 2, or (at your option) any +later version. + +Octave is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +for more details. + +You should have received a copy of the GNU General Public License +along with Octave; see the file COPYING. If not, write to the Free +Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. + +*/ + +#ifdef __GNUG__ +#pragma implementation +#endif + +#include <iostream.h> +#include <strstream.h> +#include <stdlib.h> + +#include "procstream.h" + +#include "user-prefs.h" +#include "input.h" +#include "pager.h" + +// Where we stash output headed for the screen. +static ostrstream *pager_buf; + +static int +line_count (char *s) +{ + int count = 0; + if (s != (char *) NULL) + { + char c; + while ((c = *s++) != '\0') + if (c == '\n') + count++; + } + return count; +} + +/* + * For now, use the variables from readline. It already handles + * SIGWINCH, so these values have a good chance of being correct even + * if the window changes size (they will be wrong if, for example, the + * luser changes the window size while the pager is running, and the + * signal is handled by the pager instead of us. + */ +int +terminal_columns (void) +{ + extern int screenwidth; + return screenwidth > 0 ? screenwidth : 80; +} + +int +terminal_rows (void) +{ + extern int screenheight; + return screenheight > 0 ? screenheight : 24; +} + +void +initialize_pager (void) +{ + delete pager_buf; + pager_buf = new ostrstream (); +} + +void +maybe_page_output (ostrstream& msg_buf) +{ + msg_buf << ends; + + char *message = msg_buf.str (); + + if (interactive + && user_pref.page_screen_output + && user_pref.pager_binary != (char *) NULL) + { + *pager_buf << message; + delete [] message; + } + else + { + cout << message; + cout.flush (); + delete [] message; + } +} + +void +flush_output_to_pager (void) +{ + *pager_buf << ends; + + char *message = pager_buf->str (); + + if (message == (char *) NULL || *message == '\0') + { + delete [] message; + initialize_pager (); + return; + } + + int nlines = line_count (message); + + if (nlines > terminal_rows () - 2) + { + char *pgr = user_pref.pager_binary; + if (pgr != (char *) NULL) + { + oprocstream pager_stream (pgr); + if (pager_stream) + { + pager_stream << message; + pager_stream.flush (); + + delete [] message; + initialize_pager (); + return; + } + } + } + + cout << message; + cout.flush (); + delete [] message; + initialize_pager (); +} + +/* +;;; Local Variables: *** +;;; mode: C++ *** +;;; page-delimiter: "^/\\*" *** +;;; End: *** +*/
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/pager.h Sun Aug 08 01:13:40 1993 +0000 @@ -0,0 +1,47 @@ +// pager.h -*- C++ -*- +/* + +Copyright (C) 1992, 1993 John W. Eaton + +This file is part of Octave. + +Octave is free software; you can redistribute it and/or modify it +under the terms of the GNU General Public License as published by the +Free Software Foundation; either version 2, or (at your option) any +later version. + +Octave is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +for more details. + +You should have received a copy of the GNU General Public License +along with Octave; see the file COPYING. If not, write to the Free +Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. + +*/ + +#if !defined (_pager_h) +#define _pager_h 1 + +#ifdef __GNUG__ +#pragma interface +#endif + +class ostrstream; + +extern char *get_pager (void); +extern int terminal_columns (void); +extern int terminal_rows (void); +extern void initialize_pager (void); +extern void maybe_page_output (ostrstream& msg_buf); +extern void flush_output_to_pager (void); + +#endif + +/* +;;; Local Variables: *** +;;; mode: C++ *** +;;; page-delimiter: "^/\\*" *** +;;; End: *** +*/
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/parse.h Sun Aug 08 01:13:40 1993 +0000 @@ -0,0 +1,103 @@ +// parse.h -*- C++ -*- +/* + +Copyright (C) 1992, 1993 John W. Eaton + +This file is part of Octave. + +Octave is free software; you can redistribute it and/or modify it +under the terms of the GNU General Public License as published by the +Free Software Foundation; either version 2, or (at your option) any +later version. + +Octave is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +for more details. + +You should have received a copy of the GNU General Public License +along with Octave; see the file COPYING. If not, write to the Free +Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. + +*/ + +#if !defined (_parse_h) +#define _parse_h 1 + +#include "SLStack.h" + +extern void discard_until (char c); +extern void reset_parser (void); +extern int yylex (void); +extern int yyparse (void); + +class tree; +class tree_matrix; +class tree_identifier; +class symbol_table; + +// Identifier to define if we are reading an M-fie. +extern tree_identifier *id_to_define; + +// Nonzero means we're in the middle of defining a function. +extern int defining_func; + +// Nonzero means we're in the middle of defining a loop. +extern int looping; + +// Nonzero means we're in the middle of defining a conditional expression. +extern int iffing; + +// Nonzero means we need to do some extra lookahead to avoid being +// screwed by bogus function syntax. +extern int maybe_screwed; + +// Nonzero means we need to do some extra lookahead to avoid being +// screwed by bogus function syntax. +extern int maybe_screwed_again; + +// Temporary symbol table pointer used to cope with bogus function syntax. +extern symbol_table *tmp_local_sym_tab; + +// Stack to hold list of literal matrices. +extern SLStack <tree_matrix *> ml; + +// A nonzero element corresponding to an element of ml means we just +// started reading a new matrix. This should probably be part of a +// new struct for matrix lists... +extern SLStack <int> mlnm; + +// Nonzero means print parser debugging info (-d). +extern int yydebug; + +// The current input line number. +extern int input_line_number; + +// The column of the current token. +extern int current_input_column; + +#define HELP_BUF_LENGTH 8192 + +// Buffer for help text snagged from M-files. +extern char help_buf [HELP_BUF_LENGTH]; + +// Nonzero means we're working on a plot command. +extern int plotting; + +// Nonzero means we're looking at the range part of a plot command. +extern int in_plot_range; + +// Nonzero means we're looking at the using part of a plot command. +extern int in_plot_using; + +// Nonzero means we're looking at the style part of a plot command. +extern int in_plot_style; + +#endif + +/* +;;; Local Variables: *** +;;; mode: C++ *** +;;; page-delimiter: "^/\\*" *** +;;; End: *** +*/
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/parse.y Sun Aug 08 01:13:40 1993 +0000 @@ -0,0 +1,1227 @@ +/* parse.y -*- text -*- + +Copyright (C) 1992, 1993 John W. Eaton + +This file is part of Octave. + +Octave is free software; you can redistribute it and/or modify it +under the terms of the GNU General Public License as published by the +Free Software Foundation; either version 2, or (at your option) any +later version. + +Octave is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +for more details. + +You should have received a copy of the GNU General Public License +along with Octave; see the file COPYING. If not, write to the Free +Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. + +*/ + +// Parser for Octave. + +/* + * C decarations. + */ +%{ +#define YYDEBUG 1 + +#include "SLStack.h" + +#include "Matrix.h" + +#include "error.h" +#include "variables.h" +#include "user-prefs.h" +#include "input.h" +#include "utils.h" +#include "tree.h" +#include "symtab.h" +#include "builtins.h" +#include "octave.h" +#include "parse.h" +#include "lex.h" + +// Identifier to define if we are reading an M-fie. +tree_identifier *id_to_define; + +// Nonzero means we're in the middle of defining a function. +int defining_func = 0; + +// Nonzero means we're in the middle of defining a loop. +int looping = 0; + +// Nonzero means we're in the middle of defining a conditional expression. +int iffing = 0; + +// Nonzero means we need to do some extra lookahead to avoid being +// screwed by bogus function syntax. +int maybe_screwed = 0; + +// Nonzero means we need to do some extra lookahead to avoid being +// screwed by bogus function syntax. +int maybe_screwed_again = 0; + +// Temporary symbol table pointer used to cope with bogus function syntax. +symbol_table *tmp_local_sym_tab = (symbol_table *) NULL; + +// Stack to hold list of literal matrices. +SLStack <tree_matrix *> ml; + +// A nonzero element corresponding to an element of ml means we just +// started reading a new matrix. This should probably be part of a +// new struct for matrix lists... +SLStack <int> mlnm; + +// The current input line number. +int input_line_number = 0; + +// The column of the current token. +int current_input_column = 0; + +// Buffer for help text snagged from M-files. +// Probably shouldn't be a fixed size... +char help_buf [HELP_BUF_LENGTH]; + +// Nonzero means we're working on a plot command. +int plotting = 0; + +// Nonzero means we're looking at the range part of a plot command. +int in_plot_range = 0; + +// Nonzero means we're looking at the using part of a plot command. +int in_plot_using = 0; + +// Nonzero means we're looking at the style part of a plot command. +int in_plot_style = 0; + +// The type of an END token. This declaration is repeated in lex.l. +enum end_tok_type + { + simple_end, + for_end, + function_end, + if_end, + while_end, + }; + +// The type of a PLOT token. This declaration is repeated in lex.l. +enum plot_tok_type + { + two_dee = 2, + three_dee = 3, + }; + +// Error mesages for mismatched end statements. +static void end_error (char *type, end_tok_type ettype); + +// Generic error messages. +static void yyerror (char *s); + +static tree *maybe_convert_to_ans_assign (tree *expr); +static void maybe_warn_assign_as_truth_value (tree *expr); + +#define ABORT_PARSE \ + do \ + { \ + global_command = NULL_TREE; \ + reset_parser (); \ + yyerrok; \ + if (interactive) \ + YYACCEPT; \ + else \ + YYABORT; \ + } \ + while (0) + +%} + +/* + * Bison declarations. + */ +%union +{ + tree *tree_type; + tree_constant *tree_constant_type; + tree_matrix *tree_matrix_type; + tree_identifier *tree_identifier_type; + tree_function *tree_function_type; + tree_index_expression *tree_index_expression_type; + tree_colon_expression *tree_colon_expression_type; + tree_argument_list *tree_argument_list_type; + tree_parameter_list *tree_parameter_list_type; + tree_word_list *tree_word_list_type; + tree_command *tree_command_type; + tree_if_command *tree_if_command_type; + tree_command_list *tree_command_list_type; + tree_word_list_command *tree_word_list_command_type; + tree_plot_command *tree_plot_command_type; + tree_subplot_list *tree_subplot_list_type; + tree_plot_limits *tree_plot_limits_type; + tree_plot_range *tree_plot_range_type; + tree_subplot_using *tree_subplot_using_type; + tree_subplot_style *tree_subplot_style_type; + symbol_record *sym_rec; + double number; + char *string; + end_tok_type ettype; + plot_tok_type pttype; +} + +/* + * There are 20 shift/reduce conflicts, ok? + */ +%expect 20 + +/* + * Reserved words. + */ +%token FOR WHILE IF ELSEIF ELSE FCN BREAK CONTINUE FUNC_RET SCREW_TWO +%token END_OF_INPUT GLOBAL CLEAR + +%token USING TITLE WITH COLON OPEN_BRACE CLOSE_BRACE + +// tree +%type <tree_type> input command +%type <tree_type> ans_expression expression simple_expr simple_expr1 +%type <tree_type> title + +// tree_matrix +%type <tree_matrix_type> matrix + +// tree_identifier +%type <tree_identifier_type> identifier + +// tree_function +%type <tree_function_type> func_def func_def1 func_def2 func_def3 + +// tree_index_expression +%type <tree_index_expression_type> variable + +// tree_colon_expression +%type <tree_colon_expression_type> colon_expr + +// tree_argument_list +%type <tree_argument_list_type> arg_list arg_list1 + +// tree_parameter_list +%type <tree_parameter_list_type> param_list param_list1 func_def1a + +// tree_word_list +%type <tree_word_list_type> word_list word_list1 + +// tree_command +%type <tree_command_type> statement + +// tree_if_command +%type <tree_if_command_type> elseif + +// tree_command_list +%type <tree_command_list_type> simple_list simple_list1 list list1 opt_list + +// tree_word_list_command +%type <tree_word_list_command_type> word_list_cmd + +// tree_plot_command +%type <tree_plot_command_type> plot_command + +// tree_subplot_list +%type <tree_subplot_list_type> plot_command1 plot_command2 plot_options + +// tree_plot_limits +%type <tree_plot_limits_type> ranges + +// tree_plot_range +%type <tree_plot_range_type> ranges1 + +// tree_subplot_using +%type <tree_subplot_using_type> using using1 + +// tree_subplot_style +%type <tree_subplot_style_type> style + +%token <number> NUM IMAG_NUM +%token <sym_rec> NAME SCREW +%token <string> TEXT STYLE +%token <ettype> END +%token <pttype> PLOT + +%left ';' ',' '\n' +%right '=' +%left EXPR_AND EXPR_OR +%left EXPR_LT EXPR_LE EXPR_EQ EXPR_NE EXPR_GE EXPR_GT +%left ':' +%left '-' '+' +%left '*' '/' LEFTDIV EMUL EDIV ELEFTDIV +%left QUOTE TRANSPOSE +%left UNARY PLUS_PLUS MINUS_MINUS EXPR_NOT +%right POW EPOW + +%start input + +/* + * Grammar rules. + */ +%% + +input : '\n' + { + global_command = NULL_TREE; + promptflag = 1; + YYACCEPT; + } + | END_OF_INPUT + { + global_command = NULL_TREE; + promptflag = 1; + YYABORT; + } + | simple_list '\n' + { + global_command = $1; + promptflag = 1; + YYACCEPT; + } + | simple_list END_OF_INPUT + { + global_command = $1; + promptflag = 1; + YYACCEPT; + } + | error + { ABORT_PARSE; } + | error '\n' + { ABORT_PARSE; } + | error END_OF_INPUT + { ABORT_PARSE; } + | simple_list error + { ABORT_PARSE; } + | simple_list error END_OF_INPUT + { ABORT_PARSE; } + ; + +simple_list : semi_comma + { $$ = (tree_command_list *) NULL; } + | comma_semi + { $$ = (tree_command_list *) NULL; } + | simple_list1 + { $$ = $1->reverse (); } + | simple_list1 semi_comma + { + $1->set_print_flag (0); + $$ = $1->reverse (); + } + | simple_list1 comma_semi + { $$ = $1->reverse (); } + ; + +simple_list1 : command + { $$ = new tree_command_list ($1); } + | semi_comma command + { $$ = new tree_command_list ($2); } + | comma_semi command + { $$ = new tree_command_list ($2); } + | simple_list1 semi_comma command + { + $1->set_print_flag (0); + $$ = $1->chain ($3); + } + | simple_list1 comma_semi command + { $$ = $1->chain ($3); } + ; + +semi_comma : ';' + | semi_comma ',' + | semi_comma ';' + ; + +comma_semi : ',' + | comma_semi ';' + | comma_semi ',' + ; + +comma_nl_sep : ',' + | '\n' + | comma_nl_sep sep + ; + +semi_sep : ';' + | semi_sep sep + ; + +opt_list : // empty + { $$ = new tree_command_list (); } + | list + { $$ = $1; } + +list : list1 + { $$ = $1->reverse (); } + | list1 comma_nl_sep + { $$ = $1->reverse (); } + | list1 semi_sep + { + $1->set_print_flag (0); + $$ = $1->reverse (); + } + ; + +list1 : command + { $$ = new tree_command_list ($1); } + | list1 comma_nl_sep command + { $$ = $1->chain ($3); } + | list1 semi_sep command + { + $1->set_print_flag (0); + $$ = $1->chain ($3); + } + ; + +command : plot_command + { $$ = $1; } + | statement + { $$ = $1; } + | ans_expression + { $$ = $1; } + | func_def + { $$ = $1; } + | global_decl + { $$ = NULL_TREE; } + ; + +plot_command : PLOT plot_command1 + { + tree_subplot_list *tmp = $2->reverse (); + $$ = new tree_plot_command (tmp, $1); + plotting = 0; + in_plot_range = 0; + in_plot_using = 0; + in_plot_style = 0; + } + | PLOT ranges plot_command1 + { + tree_subplot_list *tmp = $3->reverse (); + $$ = new tree_plot_command (tmp, $2, $1); + plotting = 0; + in_plot_range = 0; + in_plot_using = 0; + in_plot_style = 0; + } + ; + +ranges : ranges1 + { $$ = new tree_plot_limits ($1); } + | ranges1 ranges1 + { $$ = new tree_plot_limits ($1, $2); } + | ranges1 ranges1 ranges1 + { $$ = new tree_plot_limits ($1, $2, $3); } + ; + +ranges1 : OPEN_BRACE expression COLON expression CLOSE_BRACE + { $$ = new tree_plot_range ($2, $4); } + | OPEN_BRACE COLON expression CLOSE_BRACE + { $$ = new tree_plot_range (NULL, $3); } + | OPEN_BRACE expression COLON CLOSE_BRACE + { $$ = new tree_plot_range ($2, NULL); } + | OPEN_BRACE COLON CLOSE_BRACE + { $$ = new tree_plot_range (); } + | OPEN_BRACE CLOSE_BRACE + { $$ = new tree_plot_range (); } + ; + +plot_command1 : plot_command2 + { $$ = $1; } + | plot_command1 ',' plot_command2 + { $$ = $1->chain ($3); } + ; + +plot_command2 : expression + { $$ = new tree_subplot_list ($1); } + | expression plot_options + { $$ = $2->set_data ($1); } + ; + +plot_options : using + { $$ = new tree_subplot_list ($1, NULL, NULL); } + | title + { $$ = new tree_subplot_list (NULL, $1, NULL); } + | style + { $$ = new tree_subplot_list (NULL, NULL, $1); } + | using title + { $$ = new tree_subplot_list ($1, $2, NULL); } + | title using + { $$ = new tree_subplot_list ($2, $1, NULL); } + | using style + { $$ = new tree_subplot_list ($1, NULL, $2); } + | style using + { $$ = new tree_subplot_list ($2, NULL, $1); } + | title style + { $$ = new tree_subplot_list (NULL, $1, $2); } + | style title + { $$ = new tree_subplot_list (NULL, $2, $1); } + | using title style + { $$ = new tree_subplot_list ($1, $2, $3); } + | using style title + { $$ = new tree_subplot_list ($1, $3, $2); } + | title using style + { $$ = new tree_subplot_list ($2, $1, $3); } + | title style using + { $$ = new tree_subplot_list ($3, $1, $2); } + | style using title + { $$ = new tree_subplot_list ($2, $3, $1); } + | style title using + { $$ = new tree_subplot_list ($3, $2, $1); } + ; + +using : using1 + { + $$ = $1; + in_plot_using = 0; + } + | using1 expression + { + $$ = $1->set_format ($2); + in_plot_using = 0; + } + ; + +using1 : USING expression + { + tree_subplot_using *tmp = new tree_subplot_using (); + $$ = tmp->add_qualifier ($2); + } + | using1 COLON expression + { $$ = $1->add_qualifier ($3); } + ; + +title : TITLE expression + { $$ = $2; } + ; + +style : WITH STYLE + { $$ = new tree_subplot_style ($2); } + | WITH STYLE expression + { $$ = new tree_subplot_style ($2, $3); } + | WITH STYLE expression bogus_syntax expression + { $$ = new tree_subplot_style ($2, $3, $5); } + ; + +bogus_syntax : // empty + ; + +ans_expression : expression + { $$ = maybe_convert_to_ans_assign ($1); } + ; + +global_decl : GLOBAL global_decl1 + { } + ; + +global_decl1 : NAME + { force_global ($1->name ()); } + | NAME '=' expression + { + symbol_record *sr = force_global ($1->name ()); + tree_identifier *id = new tree_identifier (sr); + tree_simple_assignment_expression *expr = + new tree_simple_assignment_expression (id, $3); + expr->eval (0); + } + | global_decl1 optcomma NAME + { force_global ($3->name ()); } + | global_decl1 optcomma NAME '=' expression + { + symbol_record *sr = force_global ($3->name ()); + tree_identifier *id = new tree_identifier (sr); + tree_simple_assignment_expression *expr = + new tree_simple_assignment_expression (id, $5); + expr->eval (0); + } + ; + +optcomma : // empty + | ',' + { + if (user_pref.warn_comma_in_global_decl) + warning ("comma in global declaration not\ + interpreted as a command separator"); + } + ; + +statement : WHILE expression optsep opt_list END + { + maybe_warn_assign_as_truth_value ($2); + if ($5 != while_end && $5 != simple_end) + { + yyerror ("parse error"); + end_error ("while", $5); + ABORT_PARSE; + } + looping--; + $$ = new tree_while_command ($2, $4); + } + | FOR identifier '=' expression optsep opt_list END + { + if ($7 != for_end && $7 != simple_end) + { + yyerror ("parse error"); + end_error ("for", $7); + ABORT_PARSE; + } + looping--; + $$ = new tree_for_command ($2, $4, $6); + } + | IF expression optsep opt_list END + { + maybe_warn_assign_as_truth_value ($2); + if ($5 != if_end && $5 != simple_end) + { + yyerror ("parse error"); + end_error ("if", $5); + ABORT_PARSE; + } + iffing--; + $$ = new tree_if_command ($2, $4); + } + | IF expression optsep opt_list ELSE optsep opt_list END + { + maybe_warn_assign_as_truth_value ($2); + if ($8 != if_end && $8 != simple_end) + { + yyerror ("parse error"); + end_error ("if", $8); + ABORT_PARSE; + } + iffing--; + tree_if_command *t1 = new tree_if_command ($7); + $$ = t1->chain ($2, $4); + } + | IF expression optsep opt_list elseif END + { + maybe_warn_assign_as_truth_value ($2); + if ($6 != if_end && $6 != simple_end) + { + yyerror ("parse error"); + end_error ("if", $6); + ABORT_PARSE; + } + iffing--; + tree_if_command *t1 = $5->reverse (); + // Add the if list to the new head of the elseif + // list, and return the list. + $$ = t1->chain ($2, $4); + } + | IF expression optsep opt_list elseif ELSE optsep opt_list END + { + maybe_warn_assign_as_truth_value ($2); + if ($9 != if_end && $9 != simple_end) + { + yyerror ("parse error"); + end_error ("if", $9); + ABORT_PARSE; + } + iffing--; + // Add the else list to the head of the elseif list, + // then reverse the list. + tree_if_command *t1 = $5->chain ($8); + t1 = t1->reverse (); + // Add the if list to the new head of the elseif + // list, and return the list. + $$ = t1->chain ($2, $4); + } + | BREAK + { + if (!looping) + { + yyerror ("parse error"); + error ("break: only meaningful within a `for'\ + or `while' loop"); + ABORT_PARSE; + } + $$ = new tree_break_command (); + } + | CONTINUE + { + if (!looping) + { + yyerror ("parse error"); + error ("continue: only meaningful within a\ + `for' or `while' loop"); + ABORT_PARSE; + } + $$ = new tree_break_command (); + } + | FUNC_RET + { + if (!defining_func) + { + yyerror ("parse error"); + error ("return: only meaningful within a function"); + ABORT_PARSE; + } + $$ = new tree_return_command (); + } + ; + +elseif : ELSEIF optsep expression optsep opt_list + { + maybe_warn_assign_as_truth_value ($3); + $$ = new tree_if_command ($3, $5); + } + | elseif ELSEIF optsep expression optsep opt_list + { + maybe_warn_assign_as_truth_value ($4); + $$ = $1->chain ($4, $6); + } + ; + +optsep : // empty + | sep + ; + +sep : ',' + | ';' + | '\n' + | sep ',' + | sep ';' + | sep '\n' + ; + +screwed_again : // empty + { maybe_screwed_again++; } + ; + +expression : variable '=' expression + { $$ = new tree_simple_assignment_expression ($1, $3); } + | '[' screwed_again matrix_row SCREW_TWO '=' expression + { + +// Will need a way to convert the matrix list to a list of +// identifiers. If that fails, we can abort here, without losing +// anything -- no other possible syntax is valid if we've seen the +// equals sign as the next token after the `]'. + + $$ = (tree_multi_assignment_expression *) NULL; + maybe_screwed_again--; + tree_matrix *tmp = ml.pop (); + tmp = tmp->reverse (); + tree_return_list *id_list = tmp->to_return_list (); + if (id_list == NULL_TREE) + { + yyerror ("parse error"); + error ("invalid identifier list for assignment"); + $$ = (tree_multi_assignment_expression *) NULL; + ABORT_PARSE; + } + else + $$ = new tree_multi_assignment_expression (id_list, $6); + } + | NUM '=' expression + { + yyerror ("parse error"); + error ("invalid assignment to a number"); + $$ = (tree_simple_assignment_expression *) NULL; + ABORT_PARSE; + } + | simple_expr + { $$ = $1; } + ; + +simple_expr : simple_expr1 + { $$ = $1; } + | identifier PLUS_PLUS + { $$ = new tree_postfix_expression ($1, tree::increment); } + | identifier MINUS_MINUS + { $$ = new tree_postfix_expression ($1, tree::decrement); } + | simple_expr QUOTE + { $$ = new tree_unary_expression ($1, tree::hermitian); } + | simple_expr TRANSPOSE + { $$ = new tree_unary_expression ($1, tree::transpose); } + | simple_expr POW simple_expr + { $$ = new tree_binary_expression ($1, $3, tree::power); } + | simple_expr EPOW simple_expr + { $$ = new tree_binary_expression ($1, $3, tree::elem_pow); } + | simple_expr '+' simple_expr + { $$ = new tree_binary_expression ($1, $3, tree::add); } + | simple_expr '-' simple_expr + { $$ = new tree_binary_expression ($1, $3, tree::subtract); } + | simple_expr '*' simple_expr + { $$ = new tree_binary_expression ($1, $3, tree::multiply); } + | simple_expr '/' simple_expr + { $$ = new tree_binary_expression ($1, $3, tree::divide); } + | simple_expr EMUL simple_expr + { $$ = new tree_binary_expression ($1, $3, tree::el_mul); } + | simple_expr EDIV simple_expr + { $$ = new tree_binary_expression ($1, $3, tree::el_div); } + | simple_expr LEFTDIV simple_expr + { $$ = new tree_binary_expression ($1, $3, tree::leftdiv); } + | simple_expr ELEFTDIV simple_expr + { $$ = new tree_binary_expression ($1, $3, + tree::el_leftdiv); } + | simple_expr EXPR_LT simple_expr + { $$ = new tree_binary_expression ($1, $3, tree::cmp_lt); } + | simple_expr EXPR_LE simple_expr + { $$ = new tree_binary_expression ($1, $3, tree::cmp_le); } + | simple_expr EXPR_EQ simple_expr + { $$ = new tree_binary_expression ($1, $3, tree::cmp_eq); } + | simple_expr EXPR_GE simple_expr + { $$ = new tree_binary_expression ($1, $3, tree::cmp_ge); } + | simple_expr EXPR_GT simple_expr + { $$ = new tree_binary_expression ($1, $3, tree::cmp_gt); } + | simple_expr EXPR_NE simple_expr + { $$ = new tree_binary_expression ($1, $3, tree::cmp_ne); } + | simple_expr EXPR_AND simple_expr + { $$ = new tree_binary_expression ($1, $3, tree::and); } + | simple_expr EXPR_OR simple_expr + { $$ = new tree_binary_expression ($1, $3, tree::or); } + ; + +simple_expr1 : NUM + { $$ = new tree_constant ($1); } + | IMAG_NUM + { $$ = new tree_constant (Complex (0.0, $1)); } + | TEXT + { $$ = new tree_constant ($1); } + | word_list_cmd + { $$ = $1; } + | '(' expression ')' + { + if ($2->is_assignment_expression ()) + ((tree_assignment_expression *) $2) -> in_parens++; + $$ = $2; + } + | variable + { $$ = $1; } + | matrix + { $$ = $1; } + | colon_expr + { $$ = $1; } + | PLUS_PLUS identifier %prec UNARY + { $$ = new tree_prefix_expression ($2, tree::increment); } + | MINUS_MINUS identifier %prec UNARY + { $$ = new tree_prefix_expression ($2, tree::decrement); } + | EXPR_NOT simple_expr + { $$ = new tree_unary_expression ($2, tree::not); } + | '+' simple_expr %prec UNARY + { $$ = $2; } + | '-' simple_expr %prec UNARY + { $$ = new tree_unary_expression ($2, tree::uminus); } + ; + +colon_expr : simple_expr ':' simple_expr + { $$ = new tree_colon_expression ($1, $3); } + | colon_expr ':' simple_expr + { + $$ = $1->chain ($3); + if ($$ == (tree_colon_expression *) NULL) + { + yyerror ("parse error"); + ABORT_PARSE; + } + } + ; + +word_list_cmd : identifier word_list + { $$ = new tree_word_list_command ($1, $2); } + | CLEAR + { + if (defining_func) + { + yyerror ("parse error"); + error ("clear: invalid within function body"); + ABORT_PARSE; + } + symbol_record *sr = global_sym_tab->lookup ("clear", 1, 0); + assert (sr != (symbol_record *) NULL); + tree_identifier *tmp = new tree_identifier (sr); + $$ = new tree_word_list_command (tmp, + (tree_word_list *) NULL); + } + | CLEAR word_list + { + if (defining_func) + { + yyerror ("parse error"); + error ("clear: invalid within function body"); + ABORT_PARSE; + } + symbol_record *sr = global_sym_tab->lookup ("clear", 1, 0); + assert (sr != (symbol_record *) NULL); + tree_identifier *tmp = new tree_identifier (sr); + $$ = new tree_word_list_command (tmp, $2); + } + ; + +word_list : word_list1 + { $$ = $1->reverse (); } + ; + +word_list1 : TEXT + { $$ = new tree_word_list ($1); } + | word_list1 TEXT + { $$ = $1->chain ($2); } + ; + +// This is truly disgusting. + +g_symtab : // empty + { curr_sym_tab = global_sym_tab; } + ; + +local_symtab : // empty + { curr_sym_tab = tmp_local_sym_tab; } + ; + +safe : // empty + { maybe_screwed = 0; } + ; + +are_we_screwed : // empty + { maybe_screwed = 1; } + ; + +func_def : FCN g_symtab are_we_screwed func_def1 + { + curr_sym_tab = top_level_sym_tab; + defining_func = 0; + $$ = (tree_function *) NULL; + } + | FCN g_symtab are_we_screwed func_def2 + { + curr_sym_tab = top_level_sym_tab; + defining_func = 0; + $$ = (tree_function *) NULL; + } + ; + +func_def1 : SCREW safe g_symtab '=' func_def2 + { + tree_identifier *tmp = new tree_identifier ($1); + tree_parameter_list *tpl = new tree_parameter_list (tmp); + tpl = tpl->reverse (); + tpl->mark_as_formal_parameters (); + $$ = $5->define_ret_list (tpl); + } + | func_def1a ']' g_symtab '=' func_def2 + { + tree_parameter_list *tpl = $1->reverse (); + tpl->mark_as_formal_parameters (); + $$ = $5->define_ret_list (tpl); + } + ; + +func_def1a : '[' safe local_symtab identifier + { $$ = new tree_parameter_list ($4); } + | func_def1a ',' identifier + { $$ = $1->chain ($3); } + ; + +func_def2 : identifier safe local_symtab func_def3 + { + char *id_name = $1->name (); +// if (is_text_function_name (id_name)) +// { +// yyerror ("parse error"); +// error ("invalid use of reserved word %s", id_name); +// ABORT_PARSE; +// } + +// If input is coming from a file, issue a warning if the name of the +// file does not match the name of the function stated in the file. +// Matlab doesn't provide a diagnostic (it ignores the stated name). + + if (reading_m_file) + { + if (strcmp (curr_m_file_name, id_name) != 0) + warning ("function name `%s' does not agree\ + with M-file name `%s.m'", id_name, curr_m_file_name); + + id_to_define->define ($4); + id_to_define->document (help_buf); + } + else + { + if (reading_script_file + && strcmp (curr_m_file_name, id_name) == 0) + warning ("function `%s' defined within\ + script file `%s.m'", id_name, curr_m_file_name); + + $1->define ($4); + $1->document (help_buf); + top_level_sym_tab->clear (id_name); + } + + $$ = $4; + } + ; + +func_def3 : param_list optsep opt_list fcn_end_or_eof + { + tree_function *fcn = new tree_function ($3, curr_sym_tab); + $$ = fcn->define_param_list ($1); + } + | '(' ')' optsep opt_list fcn_end_or_eof + { $$ = new tree_function ($4, curr_sym_tab); } + | optsep opt_list fcn_end_or_eof + { $$ = new tree_function ($2, curr_sym_tab); } + ; + +fcn_end_or_eof : END + { + if ($1 != function_end && $1 != simple_end) + { + yyerror ("parse error"); + end_error ("function", $1); + ABORT_PARSE; + } + + if (reading_m_file) + check_for_garbage_after_fcn_def (); + } + | END_OF_INPUT + { + if (! (reading_m_file || reading_script_file)) + YYABORT; + } + ; + +variable : identifier + { $$ = new tree_index_expression ($1); } + | identifier '(' arg_list ')' + { $$ = new tree_index_expression ($1, $3); } + | identifier '(' ')' + { + $$ = new tree_index_expression + ($1, (tree_argument_list *) NULL); + } + | identifier '[' + { + yyerror ("parse error"); + error ("use `(\' and `)\' as index operators, not\ + `[\' and `]\'"); + $$ = (tree_index_expression *) NULL; + ABORT_PARSE; + } + ; + +param_list : param_list1 ')' + { + tree_parameter_list *tmp = $1->reverse (); + tmp->mark_as_formal_parameters (); + $$ = tmp; + } + +param_list1 : '(' identifier + { $$ = new tree_parameter_list ($2); } + | param_list1 ',' identifier + { $$ = $1->chain ($3); } + | '(' error + { + error ("parameter lists may only contain identifiers"); + $$ = (tree_parameter_list *) NULL; + } + | param_list1 ',' error + { + error ("parameter lists may only contain identifiers"); + $$ = (tree_parameter_list *) NULL; + } + ; + +identifier : NAME + { $$ = new tree_identifier ($1); } + +arg_list : arg_list1 + { $$ = $1->reverse (); } + ; + +arg_list1 : ':' + { + tree_constant *colon; + colon = new tree_constant (tree_constant_rep::magic_colon); + $$ = new tree_argument_list (colon); + } + | arg_list1 ',' ':' + { + tree_constant *colon; + colon = new tree_constant (tree_constant_rep::magic_colon); + $$ = $1->chain (colon); + if ($$ == NULL_TREE) + { + yyerror ("parse error"); + ABORT_PARSE; + } + } + | expression + { $$ = new tree_argument_list ($1); } + | arg_list1 ',' expression + { + $$ = $1->chain ($3); + if ($$ == NULL_TREE) + { + yyerror ("parse error"); + ABORT_PARSE; + } + } + ; + +matrix : '[' ']' + { + mlnm.pop (); + $$ = new tree_matrix (); + } + | '[' ';' ']' + { + mlnm.pop (); + $$ = new tree_matrix (); + } + | '[' screwed_again rows ']' + { + mlnm.pop (); + maybe_screwed_again--; + tree_matrix *tmp = ml.pop (); + $$ = tmp->reverse (); + } + ; + +rows : matrix_row + | rows ';' // Ignore trailing semicolon. + | rows ';' matrix_row + ; + +matrix_row : expression // First element on row. + { + if (mlnm.top ()) + { + mlnm.pop (); + mlnm.push (0); + tree_matrix *tmp = new tree_matrix ($1, tree::md_none); + ml.push (tmp); + } + else + { + tree_matrix *tmp = ml.pop (); + tmp = tmp->chain ($1, tree::md_down); + ml.push (tmp); + } + } + | matrix_row ',' // Ignore trailing comma. + | matrix_row ',' expression + { + tree_matrix *tmp = ml.pop (); + tmp = tmp->chain ($3, tree::md_right); + ml.push (tmp); + } + ; + +%% + +static void +yyerror (char *s) +{ + char *line = current_input_line; + int err_col = current_input_column; + if (err_col == 0) + err_col = strlen (current_input_line) + 1; + +// Print a message like `parse error'. + fprintf (stderr, "\n%s", s); + +// Maybe print the line number and file name. + if (reading_m_file || reading_script_file) + fprintf (stderr, " near line %d of file %s.m", input_line_number, + curr_m_file_name); + + int len = strlen (line); + if (line[len-1] == '\n') + { + len--; + line[len] = '\0'; + } + +// Print the line, maybe with a pointer near the error token. + if (err_col > len) + fprintf (stderr, ":\n\n %s\n\n", line); + else + fprintf (stderr, ":\n\n %s\n %*s\n\n", line, err_col, "^"); +} + +static void +end_error (char *type, end_tok_type ettype) +{ + switch (ettype) + { + case simple_end: + error ("%s command matched by `end'", type); + break; + case for_end: + error ("%s command matched by `endfor'", type); + break; + case function_end: + error ("%s command matched by `endfunction'", type); + break; + case if_end: + error ("%s command matched by `endif'", type); + break; + case while_end: + error ("%s command matched by `endwhile'", type); + break; + default: + panic_impossible (); + break; + } +} + +/* + * Need to make sure that the expression isn't already an identifier + * that has a name, or an assignment expression. + * + * Note that an expression can't be just an identifier anymore -- it + * must at least be an index expression (see the definition of the + * non-terminal `variable' above). + */ +tree * +maybe_convert_to_ans_assign (tree *expr) +{ + tree *retval = expr; + + symbol_record *sr = global_sym_tab->lookup ("ans", 1, 0); + + assert (sr != (symbol_record *) NULL); + + if (expr->is_index_expression ()) + { + tree_index_expression *idx_expr = (tree_index_expression *) expr; + tree_argument_list *args = idx_expr->arg_list (); + + if (args == (tree_argument_list *) NULL) + { + tree_identifier *tmp = idx_expr->ident (); + tree *defn = tmp->def (); + if (defn != NULL_TREE && ! defn->is_builtin ()) + { + return retval; + } + } + } + else if (expr->is_assignment_expression ()) + { + return retval; + } + + tree_identifier *ans = new tree_identifier (sr); + retval = new tree_simple_assignment_expression (ans, expr); + + return retval; +} + +void +maybe_warn_assign_as_truth_value (tree *expr) +{ + if (user_pref.warn_assign_as_truth_value + && expr->is_assignment_expression () + && ((tree_assignment_expression *) expr) -> in_parens < 2) + { + warning ("suggest parenthesis around assignment used as truth value"); + } +}
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/pr-output.cc Sun Aug 08 01:13:40 1993 +0000 @@ -0,0 +1,1261 @@ +// pr-output.cc -*- C++ -*- +/* + +Copyright (C) 1992, 1993 John W. Eaton + +This file is part of Octave. + +Octave is free software; you can redistribute it and/or modify it +under the terms of the GNU General Public License as published by the +Free Software Foundation; either version 2, or (at your option) any +later version. + +Octave is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +for more details. + +You should have received a copy of the GNU General Public License +along with Octave; see the file COPYING. If not, write to the Free +Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. + +*/ + +#ifdef __GNUG__ +#pragma implementation +#endif + +#include <iostream.h> +#include <strstream.h> +#include <string.h> +#include <math.h> +#include <float.h> +#include <Complex.h> + +#include "Range.h" +#include "Matrix.h" + +#include "tree-const.h" +#include "variables.h" +#include "user-prefs.h" +#include "pr-output.h" +#include "mappers.h" +#include "pager.h" +#include "error.h" +#include "utils.h" + +// Current format string for real numbers and the real part of complex +// numbers. +static char *curr_real_fmt = (char *) NULL; + +// Current format string for the imaginary part of complex numbers. +static char *curr_imag_fmt = (char *) NULL; + +// Nonzero means don\'t do any fancy formatting. +static int free_format = 0; + +// Nonzero means print plus sign for nonzero, blank for zero. +static int plus_format = 0; + +// Nonzero means always print like dollars and cents. +static int bank_format = 0; + +// Nonzero means use an e format. +static int print_e = 0; + +// Nonzero means print E instead of e for exponent field. +static int print_big_e = 0; + +static int +any_element_is_negative (const Matrix& a) +{ + int nr = a.rows (); + int nc = a.columns (); + for (int j = 0; j < nc; j++) + for (int i = 0; i < nr; i++) + if (a.elem (i, j) < 0.0) + return 1; + return 0; +} + +static int +any_element_is_inf_or_nan (const Matrix& a) +{ + int nr = a.rows (); + int nc = a.columns (); + for (int j = 0; j < nc; j++) + for (int i = 0; i < nr; i++) + { + double val = a.elem (i, j); + if (xisinf (val) || xisnan (val)) + return 1; + } + return 0; +} + +static int +any_element_is_inf_or_nan (const ComplexMatrix& a) +{ + int nr = a.rows (); + int nc = a.columns (); + for (int j = 0; j < nc; j++) + for (int i = 0; i < nr; i++) + { + Complex val = a.elem (i, j); + if (xisinf (val) || xisnan (val)) + return 1; + } + return 0; +} + +static int +all_elements_are_int_or_inf_or_nan (const Matrix& a) +{ + int nr = a.rows (); + int nc = a.columns (); + for (int j = 0; j < nc; j++) + for (int i = 0; i < nr; i++) + { + double val = a.elem (i, j); + if (xisnan (val) || D_NINT (val) == val) + continue; + else + return 0; + } + return 1; +} + +static Matrix +abs (const Matrix& a) +{ + int nr = a.rows (); + int nc = a.columns (); + Matrix retval (nr, nc); + for (int j = 0; j < nc; j++) + for (int i = 0; i < nr; i++) + retval.elem (i, j) = fabs (a.elem (i, j)); + return retval; +} + +static double +pr_max_internal (Matrix& m) +{ + int nr = m.rows (); + int nc = m.columns (); + + double result = DBL_MIN; + + for (int j = 0; j < nc; j++) + for (int i = 0; i < nr; i++) + { + double val = m.elem (i, j); + if (xisinf (val) || xisnan (val)) + continue; + + if (val > result) + result = val; + } + return result; +} + +static double +pr_min_internal (Matrix& m) +{ + int nr = m.rows (); + int nc = m.columns (); + + double result = DBL_MAX; + + for (int j = 0; j < nc; j++) + for (int i = 0; i < nr; i++) + { + double val = m.elem (i, j); + if (xisinf (val) || xisnan (val)) + continue; + + if (val < result) + result = val; + } + return result; +} + +static void +set_format (double d, int& fw) +{ + curr_real_fmt = (char *) NULL; + curr_imag_fmt = (char *) NULL; + + if (free_format) + return; + + static char fmt_buf[32]; + + int sign = (d < 0.0); + + int inf_or_nan = (xisinf (d) || xisnan (d)); + + double d_abs = d < 0.0 ? -d : d; + + int digits = d_abs == 0.0 ? 0 : (int) floor (log10 (d_abs) + 1.0); + + int prec = user_pref.output_precision; + + int ld, rd; + + if (bank_format) + { + fw = digits < 0 ? 4 : digits + 3; + if (inf_or_nan && fw < 3) + fw = 3; + fw += sign; + rd = 2; + } + else if (xisnan (d) || D_NINT (d) == d) + { + fw = digits; + if (inf_or_nan && fw < 3) + fw = 3; + fw += sign; + rd = 0; + } + else + { + if (digits > 0) + { + ld = digits; + rd = prec - digits; + digits++; + } + else + { + ld = 1; + rd = prec - digits; + digits = -digits + 1; + } + + fw = ld + 1 + rd; + if (inf_or_nan && fw < 3) + fw = 3; + fw += sign; + } + + if (! bank_format && (fw > user_pref.output_max_field_width || print_e)) + { + int exp_field = 4; + if (digits > 100) + exp_field++; + + fw = 2 + prec + exp_field; + if (inf_or_nan && fw < 3) + fw = 3; + fw += sign; + + if (print_big_e) + sprintf (fmt_buf, "%%%d.%dE", fw, prec - 1); + else + sprintf (fmt_buf, "%%%d.%de", fw, prec - 1); + } + else + { + sprintf (fmt_buf, "%%%d.%df", fw, rd); + } + + curr_real_fmt = &fmt_buf[0]; +} + +static inline void +set_format (double d) +{ + int fw; + set_format (d, fw); +} + +static void +set_format (Matrix& m, int& fw) +{ + curr_real_fmt = (char *) NULL; + curr_imag_fmt = (char *) NULL; + + if (free_format) + return; + + static char fmt_buf[32]; + + int sign = any_element_is_negative (m); + + int inf_or_nan = any_element_is_inf_or_nan (m); + + Matrix m_abs = abs (m); + double max_abs = pr_max_internal (m_abs); + double min_abs = pr_min_internal (m_abs); + + int x_max = max_abs == 0.0 ? 0 : (int) floor (log10 (max_abs) + 1.0); + int x_min = min_abs == 0.0 ? 0 : (int) floor (log10 (min_abs) + 1.0); + + int prec = user_pref.output_precision; + + int ld, rd; + + if (bank_format) + { + int digits = x_max > x_min ? x_max : x_min; + fw = digits <= 0 ? 4 : digits + 3; + if (inf_or_nan && fw < 3) + fw = 3; + fw += sign; + rd = 2; + } + else if (all_elements_are_int_or_inf_or_nan (m)) + { + int digits = x_max > x_min ? x_max : x_min; + fw = digits <= 0 ? 1 : digits; + if (inf_or_nan && fw < 3) + fw = 3; + fw += sign; + rd = 0; + } + else + { + int ld_max, rd_max; + if (x_max > 0) + { + ld_max = x_max; + rd_max = prec - x_max; + x_max++; + } + else + { + ld_max = 1; + rd_max = prec - x_max; + x_max = -x_max + 1; + } + + int ld_min, rd_min; + if (x_min > 0) + { + ld_min = x_min; + rd_min = prec - x_min; + x_min++; + } + else + { + ld_min = 1; + rd_min = prec - x_min; + x_min = -x_min + 1; + } + + ld = ld_max > ld_min ? ld_max : ld_min; + rd = rd_max > rd_min ? rd_max : rd_min; + + fw = ld + 1 + rd; + if (inf_or_nan && fw < 3) + fw = 3; + fw += sign; + } + + if (! bank_format && (fw > user_pref.output_max_field_width || print_e)) + { + int exp_field = 4; + if (x_max > 100 || x_min > 100) + exp_field++; + + fw = 2 + prec + exp_field; + if (inf_or_nan && fw < 3) + fw = 3; + fw += sign; + + if (print_big_e) + sprintf (fmt_buf, "%%%d.%dE", fw, prec - 1); + else + sprintf (fmt_buf, "%%%d.%de", fw, prec - 1); + } + else + { + sprintf (fmt_buf, "%%%d.%df", fw, rd); + } + + curr_real_fmt = &fmt_buf[0]; +} + +static inline void +set_format (Matrix& m) +{ + int fw; + set_format (m, fw); +} + +static void +set_format (Complex& c, int& r_fw, int& i_fw) +{ + curr_real_fmt = (char *) NULL; + curr_imag_fmt = (char *) NULL; + + if (free_format) + return; + + static char r_fmt_buf[32]; + static char i_fmt_buf[32]; + + double rp = c.real (); + double ip = c.imag (); + + int sign = (rp < 0.0); + + int inf_or_nan = (xisinf (c) || xisnan (c)); + + double r_abs = rp < 0.0 ? -rp : rp; + double i_abs = ip < 0.0 ? -ip : ip; + + int r_x = r_abs == 0.0 ? 0 : (int) floor (log10 (r_abs) + 1.0); + int i_x = i_abs == 0.0 ? 0 : (int) floor (log10 (i_abs) + 1.0); + + int x_max, x_min; + + if (r_x > i_x) + { + x_max = r_x; + x_min = i_x; + } + else + { + x_max = i_x; + x_min = r_x; + } + + int prec = user_pref.output_precision; + + int ld, rd; + + if (bank_format) + { + int digits = r_x; + i_fw = 0; + r_fw = digits <= 0 ? 4 : digits + 3; + if (inf_or_nan && r_fw < 3) + r_fw = 3; + r_fw += sign; + rd = 2; + } + else if (inf_or_nan || (D_NINT (rp) == rp && D_NINT (ip) == ip)) + { + int digits = x_max > x_min ? x_max : x_min; + i_fw = r_fw = digits <= 0 ? 1 : digits; + if (inf_or_nan && i_fw < 3) + i_fw = r_fw = 3; + r_fw += sign; + rd = 0; + } + else + { + int ld_max, rd_max; + if (x_max > 0) + { + ld_max = x_max; + rd_max = prec - x_max; + x_max++; + } + else + { + ld_max = 1; + rd_max = prec - x_max; + x_max = -x_max + 1; + } + + int ld_min, rd_min; + if (x_min > 0) + { + ld_min = x_min; + rd_min = prec - x_min; + x_min++; + } + else + { + ld_min = 1; + rd_min = prec - x_min; + x_min = -x_min + 1; + } + + ld = ld_max > ld_min ? ld_max : ld_min; + rd = rd_max > rd_min ? rd_max : rd_min; + + i_fw = r_fw = ld + 1 + rd; + if (inf_or_nan && i_fw < 3) + i_fw = r_fw = 3; + r_fw += sign; + } + + if (! bank_format && (r_fw > user_pref.output_max_field_width || print_e)) + { + int exp_field = 4; + if (x_max > 100 || x_min > 100) + exp_field++; + + i_fw = r_fw = 1 + prec + exp_field; + if (inf_or_nan && i_fw < 3) + i_fw = r_fw = 3; + r_fw += sign; + + if (print_big_e) + { + sprintf (r_fmt_buf, "%%%d.%dE", r_fw, prec - 1); + sprintf (i_fmt_buf, "%%%d.%dE", i_fw, prec - 1); + } + else + { + sprintf (r_fmt_buf, "%%%d.%de", r_fw, prec - 1); + sprintf (i_fmt_buf, "%%%d.%de", i_fw, prec - 1); + } + } + else + { + sprintf (r_fmt_buf, "%%%d.%df", r_fw, rd); + sprintf (i_fmt_buf, "%%%d.%df", i_fw, rd); + } + + curr_real_fmt = &r_fmt_buf[0]; + curr_imag_fmt = &i_fmt_buf[0]; +} + +static inline void +set_format (Complex& c) +{ + int r_fw, i_fw; + set_format (c, r_fw, i_fw); +} + +static void +set_format (ComplexMatrix& cm, int& r_fw, int& i_fw) +{ + curr_real_fmt = (char *) NULL; + curr_imag_fmt = (char *) NULL; + + if (free_format) + return; + + static char r_fmt_buf[32]; + static char i_fmt_buf[32]; + + Matrix rp = real (cm); + Matrix ip = imag (cm); + + int sign = any_element_is_negative (rp); + + int inf_or_nan = any_element_is_inf_or_nan (cm); + + Matrix r_m_abs = abs (rp); + double r_max_abs = pr_max_internal (r_m_abs); + double r_min_abs = pr_min_internal (r_m_abs); + + Matrix i_m_abs = abs (ip); + double i_max_abs = pr_max_internal (i_m_abs); + double i_min_abs = pr_min_internal (i_m_abs); + + int r_x_max = r_max_abs == 0.0 ? 0 : (int) floor (log10 (r_max_abs) + 1.0); + int r_x_min = r_min_abs == 0.0 ? 0 : (int) floor (log10 (r_min_abs) + 1.0); + + int i_x_max = i_max_abs == 0.0 ? 0 : (int) floor (log10 (i_max_abs) + 1.0); + int i_x_min = i_min_abs == 0.0 ? 0 : (int) floor (log10 (i_min_abs) + 1.0); + + int x_max = r_x_max > i_x_max ? r_x_max : i_x_max; + int x_min = r_x_min > i_x_min ? r_x_min : i_x_min; + + int prec = user_pref.output_precision; + + int ld, rd; + + if (bank_format) + { + int digits = r_x_max > r_x_min ? r_x_max : r_x_min; + i_fw = 0; + r_fw = digits <= 0 ? 4 : digits + 3; + if (inf_or_nan && i_fw < 3) + i_fw = r_fw = 3; + r_fw += sign; + rd = 2; + } + else if (all_elements_are_int_or_inf_or_nan (rp) + && all_elements_are_int_or_inf_or_nan (ip)) + { + int digits = x_max > x_min ? x_max : x_min; + i_fw = r_fw = digits <= 0 ? 1 : digits; + if (inf_or_nan && i_fw < 3) + i_fw = r_fw = 3; + r_fw += sign; + rd = 0; + } + else + { + int ld_max, rd_max; + if (x_max > 0) + { + ld_max = x_max; + rd_max = prec - x_max; + x_max++; + } + else + { + ld_max = 1; + rd_max = prec - x_max; + x_max = -x_max + 1; + } + + int ld_min, rd_min; + if (x_min > 0) + { + ld_min = x_min; + rd_min = prec - x_min; + x_min++; + } + else + { + ld_min = 1; + rd_min = prec - x_min; + x_min = -x_min + 1; + } + + ld = ld_max > ld_min ? ld_max : ld_min; + rd = rd_max > rd_min ? rd_max : rd_min; + + i_fw = r_fw = ld + 1 + rd; + if (inf_or_nan && i_fw < 3) + i_fw = r_fw = 3; + r_fw += sign; + } + + if (! bank_format && (r_fw > user_pref.output_max_field_width || print_e)) + { + int exp_field = 4; + if (x_max > 100 || x_min > 100) + exp_field++; + + i_fw = r_fw = 1 + prec + exp_field; + if (inf_or_nan && i_fw < 3) + i_fw = r_fw = 3; + r_fw += sign; + + if (print_big_e) + { + sprintf (r_fmt_buf, "%%%d.%dE", r_fw, prec - 1); + sprintf (i_fmt_buf, "%%%d.%dE", i_fw, prec - 1); + } + else + { + sprintf (r_fmt_buf, "%%%d.%de", r_fw, prec - 1); + sprintf (i_fmt_buf, "%%%d.%de", i_fw, prec - 1); + } + } + else + { + sprintf (r_fmt_buf, "%%%d.%df", r_fw, rd); + sprintf (i_fmt_buf, "%%%d.%df", i_fw, rd); + } + + curr_real_fmt = &r_fmt_buf[0]; + curr_imag_fmt = &i_fmt_buf[0]; +} + +static int +all_elements_are_ints (Range& r) +{ +// If the base and increment are ints, the final value in the range +// will also be an integer, even if the limit is not. + + double b = r.base (); + double i = r.inc (); + + return ((double) NINT (b) == b && (double) NINT (i) == i); +} + +static inline void +set_format (ComplexMatrix& cm) +{ + int r_fw, i_fw; + set_format (cm, r_fw, i_fw); +} + +static void +set_format (Range& r, int& fw) +{ + curr_real_fmt = (char *) NULL; + curr_imag_fmt = (char *) NULL; + + if (free_format) + return; + + static char fmt_buf[32]; + + double r_min = r.base (); + double r_max = r.limit (); + + if (r_max < r_min) + { + double tmp = r_max; + r_max = r_min; + r_min = tmp; + } + + int sign = (r_min < 0.0); + + double max_abs = r_max < 0.0 ? -r_max : r_max; + double min_abs = r_min < 0.0 ? -r_min : r_min; + + int x_max = max_abs == 0.0 ? 0 : (int) floor (log10 (max_abs) + 1.0); + int x_min = min_abs == 0.0 ? 0 : (int) floor (log10 (min_abs) + 1.0); + + int prec = user_pref.output_precision; + + int ld, rd; + + if (bank_format) + { + int digits = x_max > x_min ? x_max : x_min; + fw = sign + digits < 0 ? 4 : digits + 3; + rd = 2; + } + else if (all_elements_are_ints (r)) + { + int digits = x_max > x_min ? x_max : x_min; + fw = sign + digits; + rd = 0; + } + else + { + int ld_max, rd_max; + if (x_max > 0) + { + ld_max = x_max; + rd_max = prec - x_max; + x_max++; + } + else + { + ld_max = 1; + rd_max = prec - x_max; + x_max = -x_max + 1; + } + + int ld_min, rd_min; + if (x_min > 0) + { + ld_min = x_min; + rd_min = prec - x_min; + x_min++; + } + else + { + ld_min = 1; + rd_min = prec - x_min; + x_min = -x_min + 1; + } + + ld = ld_max > ld_min ? ld_max : ld_min; + rd = rd_max > rd_min ? rd_max : rd_min; + + fw = sign + ld + 1 + rd; + } + + if (! bank_format && (fw > user_pref.output_max_field_width || print_e)) + { + int exp_field = 4; + if (x_max > 100 || x_min > 100) + exp_field++; + + fw = sign + 2 + prec + exp_field; + + if (print_big_e) + sprintf (fmt_buf, "%%%d.%dE", fw, prec - 1); + else + sprintf (fmt_buf, "%%%d.%de", fw, prec - 1); + } + else + { + sprintf (fmt_buf, "%%%d.%df", fw, rd); + } + + curr_real_fmt = &fmt_buf[0]; +} + +static inline void +set_format (Range& r) +{ + int fw; + set_format (r, fw); +} + +static inline void +pr_any_float (char *fmt, ostrstream& os, double d, int fw = 0) +{ + if (d == -0.0) + d = 0.0; + + if (fmt == (char *) NULL) + os << d; + else + { + if (xisinf (d)) + { + char *s; + if (d < 0.0) + s = "-Inf"; + else + s = "Inf"; + + if (fw > 0) + os.form ("%*s", fw, s); + else + os << s; + } + else if (xisnan (d)) + { + if (fw > 0) + os.form ("%*s", fw, "NaN"); + else + os << "NaN"; + } + else + os.form (fmt, d); + } +} + +static inline void +pr_float (ostrstream& os, double d, int fw = 0) +{ + pr_any_float (curr_real_fmt, os, d, fw); +} + +static inline void +pr_imag_float (ostrstream& os, double d, int fw = 0) +{ + pr_any_float (curr_imag_fmt, os, d, fw); +} + +static inline void +pr_complex (ostrstream& os, Complex& c, int r_fw = 0, int i_fw = 0) +{ + double r = c.real (); + pr_float (os, r, r_fw); + if (! bank_format) + { + double i = c.imag (); + if (i < 0) + { + os << " - "; + i = -i; + pr_imag_float (os, i, i_fw); + } + else + { + os << " + "; + pr_imag_float (os, i, i_fw); + } + os << "i"; + } +} + +void +octave_print_internal (ostrstream& os, double d) +{ + if (plus_format) + { + if (d == 0.0) + os << " "; + else + os << "+"; + } + else + { + set_format (d); + if (free_format) + os << d; + else + pr_float (os, d); + } + os << "\n"; +} + +void +octave_print_internal (ostrstream& os, Matrix& m) +{ + int nr = m.rows (); + int nc = m.columns (); + + if (plus_format) + { + for (int i = 0; i < nr; i++) + { + for (int j = 0; j < nc; j++) + { + if (j == 0) + os << " "; + + if (m.elem (i, j) == 0.0) + os << " "; + else + os << "+"; + } + os << "\n"; + } + } + else + { + int fw; + set_format (m, fw); + int column_width = fw + 2; + int total_width = nc * column_width; + int max_width = terminal_columns (); + + if (free_format) + { + os << m; + return; + } + + int inc = nc; + if (total_width > max_width && user_pref.split_long_rows) + { + inc = max_width / column_width; + if (inc == 0) + inc++; + } + + int col = 0; + while (col < nc) + { + int lim = col + inc < nc ? col + inc : nc; + + if (total_width > max_width && user_pref.split_long_rows) + { + if (col != 0) + os << "\n"; + + int num_cols = lim - col; + if (num_cols == 1) + os << " Column " << col + 1 << ":\n\n"; + else if (num_cols == 2) + os << " Columns " << col + 1 << " and " << lim << ":\n\n"; + else + os << " Columns " << col + 1 << " through " << lim << ":\n\n"; + } + + for (int i = 0; i < nr; i++) + { + for (int j = col; j < lim; j++) + { + os << " "; + pr_float(os, m.elem (i, j), fw); + } + os << "\n"; + } + col += inc; + } + } +} + +void +octave_print_internal (ostrstream& os, Complex& c) +{ + if (plus_format) + { + if (c == 0.0) + os << " "; + else + os << "+"; + } + else + { + set_format (c); + if (free_format) + os << c; + else + pr_complex (os, c); + } + os << "\n"; +} + +void +octave_print_internal (ostrstream& os, ComplexMatrix& cm) +{ + int nr = cm.rows (); + int nc = cm.columns (); + + if (plus_format) + { + for (int i = 0; i < nr; i++) + { + for (int j = 0; j < nc; j++) + { + if (j == 0) + os << " "; + + if (cm.elem (i, j) == 0.0) + os << " "; + else + os << "+"; + } + os << "\n"; + } + } + else + { + int r_fw, i_fw; + set_format (cm, r_fw, i_fw); + int column_width = i_fw + r_fw; + column_width += bank_format ? 2 : 7; + int total_width = nc * column_width; + int max_width = terminal_columns (); + + if (free_format) + { + os << cm; + return; + } + + int inc = nc; + if (total_width > max_width && user_pref.split_long_rows) + { + inc = max_width / column_width; + if (inc == 0) + inc++; + } + + int col = 0; + while (col < nc) + { + int lim = col + inc < nc ? col + inc : nc; + + if (total_width > max_width && user_pref.split_long_rows) + { + if (col != 0) + os << "\n"; + + int num_cols = lim - col; + if (num_cols == 1) + os << " Column " << col + 1 << ":\n\n"; + else if (num_cols == 2) + os << " Columns " << col + 1 << " and " << lim << ":\n\n"; + else + os << " Columns " << col + 1 << " through " << lim << ":\n\n"; + } + + for (int i = 0; i < nr; i++) + { + for (int j = col; j < lim; j++) + { + if (bank_format) + os << " "; + else + os << " "; + pr_complex (os, cm.elem (i, j), r_fw, i_fw); + } + os << "\n"; + } + col += inc; + } + } +} + +void +octave_print_internal (ostrstream& os, Range& r) +{ + double b = r.base (); + double increment = r.inc (); + int num_elem = r.nelem (); + + if (plus_format) + { + os << " "; + for (int i = 0; i < num_elem; i++) + { + double val = b + i * increment; + if (val == 0.0) + os << " "; + else + os << "+"; + } + } + else + { + int fw; + set_format (r, fw); + int column_width = fw + 2; + int total_width = num_elem * column_width; + int max_width = terminal_columns (); + + if (free_format) + { + os << r; + return; + } + + int inc = num_elem; + if (total_width > max_width && user_pref.split_long_rows) + { + inc = max_width / column_width; + if (inc == 0) + inc++; + } + + int col = 0; + while (col < num_elem) + { + int lim = col + inc < num_elem ? col + inc : num_elem; + + if (total_width > max_width && user_pref.split_long_rows) + { + if (col != 0) + os << "\n"; + + int num_cols = lim - col; + if (num_cols == 1) + os << " Column " << col + 1 << ":\n\n"; + else if (num_cols == 2) + os << " Columns " << col + 1 << " and " << lim << ":\n\n"; + else + os << " Columns " << col + 1 << " through " << lim << ":\n\n"; + } + + for (int i = col; i < lim; i++) + { + double val = b + i * increment; + os << " "; + pr_float (os, val, fw); + } + + os << "\n"; + + col += inc; + } + } +} + +static void +init_format_state (void) +{ + free_format = 0; + plus_format = 0; + bank_format = 0; + print_e = 0; + print_big_e = 0; +} + +static void +set_output_prec_and_fw (int prec, int fw) +{ + tree_constant *tmp = NULL_TREE_CONST; + + tmp = new tree_constant ((double) prec); + bind_variable ("output_precision", tmp); + + tmp = new tree_constant ((double) fw); + bind_variable ("output_max_field_width", tmp); +} + +void +set_format_style (int argc, char **argv) +{ + if (--argc > 0) + { + argv++; + if (*argv[0]) + { + if (strcmp (*argv, "short") == 0) + { + if (--argc > 0) + { + argv++; + if (strcmp (*argv, "e") == 0) + { + init_format_state (); + print_e = 1; + } + else if (strcmp (*argv, "E") == 0) + { + init_format_state (); + print_e = 1; + print_big_e = 1; + } + else + { + message ("format", + "unrecognized option `short %s'", *argv); + return; + } + } + else + init_format_state (); + + set_output_prec_and_fw (3, 8); + } + else if (strcmp (*argv, "long") == 0) + { + if (--argc > 0) + { + argv++; + if (strcmp (*argv, "e") == 0) + { + init_format_state (); + print_e = 1; + } + else if (strcmp (*argv, "E") == 0) + { + init_format_state (); + print_e = 1; + print_big_e = 1; + } + else + { + message ("format", + "unrecognized option `long %s'", *argv); + return; + } + } + else + init_format_state (); + + set_output_prec_and_fw (15, 24); + } + else if (strcmp (*argv, "hex") == 0) + message ("format", "format state `hex' not implemented"); + else if (strcmp (*argv, "+") == 0) + { + init_format_state (); + plus_format = 1; + } + else if (strcmp (*argv, "bank") == 0) + { + init_format_state (); + bank_format = 1; + } + else if (strcmp (*argv, "free") == 0) + { + init_format_state (); + free_format = 1; + } + else if (strcmp (*argv, "none") == 0) + { + init_format_state (); + free_format = 1; + } + else if (strcmp (*argv, "compact") == 0) + message ("format", "format state `compact' not implemented"); + else if (strcmp (*argv, "loose") == 0) + message ("format", "format state `loose' not implemented"); + else + message ("format", "unrecognized format state `%s'", *argv); + } + else + usage ("format [format_state]"); + } + else + { + init_format_state (); + set_output_prec_and_fw (5, 10); + } +} + +/* +;;; Local Variables: *** +;;; mode: C++ *** +;;; page-delimiter: "^/\\*" *** +;;; End: *** +*/
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/pr-output.h Sun Aug 08 01:13:40 1993 +0000 @@ -0,0 +1,53 @@ +// pr-output.h -*- C++ -*- +/* + +Copyright (C) 1992, 1993 John W. Eaton + +This file is part of Octave. + +Octave is free software; you can redistribute it and/or modify it +under the terms of the GNU General Public License as published by the +Free Software Foundation; either version 2, or (at your option) any +later version. + +Octave is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +for more details. + +You should have received a copy of the GNU General Public License +along with Octave; see the file COPYING. If not, write to the Free +Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. + +*/ + +#if !defined (_pr_output_h) +#define _pr_output_h 1 + +#ifdef __GNUG__ +#pragma interface +#endif + +class ostrstream; + +class Matrix; +class Complex; +class ComplexMatrix; +class Range; + +extern void octave_print_internal (ostrstream& os, double d); +extern void octave_print_internal (ostrstream& os, Matrix& m); +extern void octave_print_internal (ostrstream& os, Complex& c); +extern void octave_print_internal (ostrstream& os, ComplexMatrix& cm); +extern void octave_print_internal (ostrstream& os, Range& r); + +extern void set_format_style (int argc, char **argv); + +#endif + +/* +;;; Local Variables: *** +;;; mode: C++ *** +;;; page-delimiter: "^/\\*" *** +;;; End: *** +*/
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/procstream.cc Sun Aug 08 01:13:40 1993 +0000 @@ -0,0 +1,62 @@ +// procstream.cc -*- C++ -*- +/* + +Copyright (C) 1992, 1993 John W. Eaton + +This file is part of Octave. + +Octave is free software; you can redistribute it and/or modify it +under the terms of the GNU General Public License as published by the +Free Software Foundation; either version 2, or (at your option) any +later version. + +Octave is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +for more details. + +You should have received a copy of the GNU General Public License +along with Octave; see the file COPYING. If not, write to the Free +Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. + +*/ + +#ifdef __GNUG__ +#pragma implementation +#endif + +#include "procstream.h" + +procstreambase::procstreambase (void) +{ + init (new procbuf ()); +} + +procstreambase::procstreambase (const char *command, int mode = ios::out) +{ + init (new procbuf ()); + if (! rdbuf()->open (command, mode)) + set (ios::badbit); +} + +void +procstreambase::open (const char *command, int mode = ios::out) +{ + clear (); + if (! rdbuf()->open (command, mode)) + set (ios::badbit); +} + +void +procstreambase::close (void) +{ + if (! rdbuf()->close ()) + set (ios::failbit); +} + +/* +;;; Local Variables: *** +;;; mode: C++ *** +;;; page-delimiter: "^/\\*" *** +;;; End: *** +*/
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/procstream.h Sun Aug 08 01:13:40 1993 +0000 @@ -0,0 +1,78 @@ +// procstream.h -*- C++ -*- +/* + +Copyright (C) 1992, 1993 John W. Eaton + +This file is part of Octave. + +Octave is free software; you can redistribute it and/or modify it +under the terms of the GNU General Public License as published by the +Free Software Foundation; either version 2, or (at your option) any +later version. + +Octave is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +for more details. + +You should have received a copy of the GNU General Public License +along with Octave; see the file COPYING. If not, write to the Free +Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. + +*/ + +#if !defined (_procstream_h) +#define _procstream_h 1 + +#ifdef __GNUG__ +#pragma interface +#endif + +#include <iostream.h> +#include <procbuf.h> + +class +procstreambase : virtual public ios +{ + public: + procstreambase (void); + procstreambase (const char *command, int mode = ios::out); + + procbuf *rdbuf (void) const { return (procbuf *) _strbuf; } + + void open (const char *command, int mode = ios::out); + int is_open (void) { return rdbuf()->is_open (); } + void close (void); +}; + +class +iprocstream : public procstreambase, public istream +{ + public: + iprocstream (void) : procstreambase () {} + iprocstream (const char *command) : procstreambase (command, ios::in) {} + + void open (const char *command) { procstreambase::open (command, ios::in); } +}; + +class +oprocstream : public procstreambase, public ostream +{ + public: + oprocstream (void) : procstreambase () {} + oprocstream (const char *command) : procstreambase (command, ios::out) {} + + void open (const char *command) { procstreambase::open (command, ios::out); } +}; + +#endif + +/* +;;; Local Variables: *** +;;; mode: C++ *** +;;; page-delimiter: "^/\\*" *** +;;; End: *** +*/ + + +
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/pt-base.h Sun Aug 08 01:13:40 1993 +0000 @@ -0,0 +1,163 @@ +// tree-base.h -*- C++ -*- +/* + +Copyright (C) 1992, 1993 John W. Eaton + +This file is part of Octave. + +Octave is free software; you can redistribute it and/or modify it +under the terms of the GNU General Public License as published by the +Free Software Foundation; either version 2, or (at your option) any +later version. + +Octave is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +for more details. + +You should have received a copy of the GNU General Public License +along with Octave; see the file COPYING. If not, write to the Free +Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. + +*/ + +#if !defined (_tree_base_h) +#define _tree_base_h 1 + +// NOTE: don\'t put #pragma interface here because there is no +// corresponding tree-base.cc file that implements this class! + +#ifndef NULL_TREE +#define NULL_TREE (tree *)NULL +#endif + +#ifndef NULL_TREE_CONST +#define NULL_TREE_CONST (tree_constant *)NULL +#endif + +#include <time.h> +#include <assert.h> + +class tree_constant; +class tree_identifier; +class tree_argument_list; + +/* + * Base class for the parse tree. + */ +class +tree +{ +public: + enum matrix_dir + { + md_none, + md_right, + md_down, + }; + + enum expression_type + { + unknown, + assignment, + simple_assignment, + multi_assignment, + add, + subtract, + multiply, + el_mul, + divide, + el_div, + leftdiv, + el_leftdiv, + power, + elem_pow, + cmp_lt, + cmp_le, + cmp_eq, + cmp_ge, + cmp_gt, + cmp_ne, + and, + or, + not, + unot, + uminus, + hermitian, + transpose, + colon, + index, + increment, + decrement, + }; + + virtual ~tree (void) { } + +// Only the finest cheese... + virtual int is_identifier (void) + { return 0; } + + virtual int is_constant (void) + { return 0; } + + virtual int is_builtin (void) + { return 0; } + + virtual int is_index_expression (void) + { return 0; } + + virtual int is_assignment_expression (void) + { return 0; } + + virtual tree *def (void) + { assert (0); return (tree *) NULL; } + + virtual char *name (void) + { assert (0); return (char *) NULL; } + + virtual int max_expected_args (void) + { assert (0); return 0; } + + virtual void set_print_flag (int print) + { assert (0); } + + virtual tree_constant assign (tree_constant& t, tree_constant *args, + int nargs); + + virtual void bump_value (tree::expression_type) + { assert (0); } + + virtual void stash_m_file_name (char *s) + { assert (0); } + + virtual void stash_m_file_time (time_t t) + { assert (0); } + + virtual char *m_file_name (void) + { return (char *) NULL; } + + virtual time_t time_parsed (void) + { assert (0); return 0; } + + virtual tree_constant eval (int print) = 0; + + virtual tree_constant *eval (int print, int nargout); + + virtual tree_constant eval (int argc, char **argv, int print); + + virtual tree_constant *eval (tree_constant *args, int n_in, int nout, + int print) + { assert (0); return NULL_TREE_CONST; } + + virtual int save (ostream& os, int mark_as_global = 0) + { assert (0); return 0; } +}; + +#endif + +/* +;;; Local Variables: *** +;;; mode: C++ *** +;;; page-delimiter: "^/\\*" *** +;;; End: *** +*/
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/pt-const.cc Sun Aug 08 01:13:40 1993 +0000 @@ -0,0 +1,2399 @@ +// The constants for the tree class. -*- C++ -*- +/* + +Copyright (C) 1992, 1993 John W. Eaton + +This file is part of Octave. + +Octave is free software; you can redistribute it and/or modify it +under the terms of the GNU General Public License as published by the +Free Software Foundation; either version 2, or (at your option) any +later version. + +Octave is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +for more details. + +You should have received a copy of the GNU General Public License +along with Octave; see the file COPYING. If not, write to the Free +Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. + +*/ + +#ifdef __GNUG__ +#pragma implementation +#endif + +#include <ctype.h> +#include <string.h> +#include <iostream.h> +#include <strstream.h> +#include <math.h> + +#include "variables.h" +#include "error.h" +#include "gripes.h" +#include "user-prefs.h" +#include "utils.h" +#include "pager.h" +#include "mappers.h" +#include "pr-output.h" +#include "tree-const.h" +#include "arith-ops.h" + +// A couple of handy helper functions. + +static int +any_element_is_negative (const Matrix& a) +{ + int nr = a.rows (); + int nc = a.columns (); + for (int j = 0; j < nc; j++) + for (int i = 0; i < nr; i++) + if (a.elem (i, j) < 0.0) + return 1; + return 0; +} + +static int +any_element_is_complex (const ComplexMatrix& a) +{ + int nr = a.rows (); + int nc = a.columns (); + for (int j = 0; j < nc; j++) + for (int i = 0; i < nr; i++) + if (imag (a.elem (i, j)) != 0.0) + return 1; + return 0; +} + +// Now, the classes. + +/* + * The real representation of constants. + */ +tree_constant_rep::tree_constant_rep (void) +{ + type_tag = unknown_constant; +} + +tree_constant_rep::tree_constant_rep (double d) +{ + scalar = d; + type_tag = scalar_constant; +} + +tree_constant_rep::tree_constant_rep (Matrix& m) +{ + if (m.rows () == 1 && m.columns () == 1) + { + scalar = m.elem (0, 0); + type_tag = scalar_constant; + } + else + { + matrix = new Matrix (m); + type_tag = matrix_constant; + } +} + +tree_constant_rep::tree_constant_rep (DiagMatrix& d) +{ + if (d.rows () == 1 && d.columns () == 1) + { + scalar = d.elem (0, 0); + type_tag = scalar_constant; + } + else + { + matrix = new Matrix (d); + type_tag = matrix_constant; + } +} + +tree_constant_rep::tree_constant_rep (RowVector& v) +{ + int len = v.capacity (); + if (len == 1) + { + scalar = v.elem (0); + type_tag = scalar_constant; + } + else + { + if (user_pref.prefer_column_vectors) + { + Matrix m (len, 1); + for (int i = 0; i < len; i++) + m.elem (i, 0) = v.elem (i); + matrix = new Matrix (m); + type_tag = matrix_constant; + } + else + { + Matrix m (1, len); + for (int i = 0; i < len; i++) + m.elem (0, i) = v.elem (i); + matrix = new Matrix (m); + type_tag = matrix_constant; + } + } +} + +tree_constant_rep::tree_constant_rep (RowVector& v, int prefer_column_vector) +{ + int len = v.capacity (); + if (len == 1) + { + scalar = v.elem (0); + type_tag = scalar_constant; + } + else + { + if (prefer_column_vector) + { + Matrix m (len, 1); + for (int i = 0; i < len; i++) + m.elem (i, 0) = v.elem (i); + matrix = new Matrix (m); + type_tag = matrix_constant; + } + else + { + Matrix m (1, len); + for (int i = 0; i < len; i++) + m.elem (0, i) = v.elem (i); + matrix = new Matrix (m); + type_tag = matrix_constant; + } + } +} + +tree_constant_rep::tree_constant_rep (ColumnVector& v) +{ + int len = v.capacity (); + if (len == 1) + { + scalar = v.elem (0); + type_tag = scalar_constant; + } + else + { + if (user_pref.prefer_column_vectors) + { + Matrix m (len, 1); + for (int i = 0; i < len; i++) + m.elem (i, 0) = v.elem (i); + matrix = new Matrix (m); + type_tag = matrix_constant; + } + else + { + Matrix m (1, len); + for (int i = 0; i < len; i++) + m.elem (0, i) = v.elem (i); + matrix = new Matrix (m); + type_tag = matrix_constant; + } + } +} + +tree_constant_rep::tree_constant_rep (ColumnVector& v, + int prefer_column_vector) +{ + int len = v.capacity (); + if (len == 1) + { + scalar = v.elem (0); + type_tag = scalar_constant; + } + else + { + if (prefer_column_vector) + { + Matrix m (len, 1); + for (int i = 0; i < len; i++) + m.elem (i, 0) = v.elem (i); + matrix = new Matrix (m); + type_tag = matrix_constant; + } + else + { + Matrix m (1, len); + for (int i = 0; i < len; i++) + m.elem (0, i) = v.elem (i); + matrix = new Matrix (m); + type_tag = matrix_constant; + } + } +} + +tree_constant_rep::tree_constant_rep (Complex c) +{ + complex_scalar = new Complex (c); + type_tag = complex_scalar_constant; +} + +tree_constant_rep::tree_constant_rep (ComplexRowVector& v) +{ + int len = v.capacity (); + if (len == 1) + { + complex_scalar = new Complex (v.elem (0)); + type_tag = complex_scalar_constant; + } + else + { + if (user_pref.prefer_column_vectors) + { + ComplexMatrix m (len, 1); + for (int i = 0; i < len; i++) + m.elem (i, 0) = v.elem (i); + complex_matrix = new ComplexMatrix (m); + type_tag = complex_matrix_constant; + } + else + { + ComplexMatrix m (1, len); + for (int i = 0; i < len; i++) + m.elem (0, i) = v.elem (i); + complex_matrix = new ComplexMatrix (m); + type_tag = complex_matrix_constant; + } + } +} + +tree_constant_rep::tree_constant_rep (ComplexMatrix& m) +{ + if (m.rows () == 1 && m.columns () == 1) + { + complex_scalar = new Complex (m.elem (0, 0)); + type_tag = complex_scalar_constant; + } + else + { + complex_matrix = new ComplexMatrix (m); + type_tag = complex_matrix_constant; + } +} + +tree_constant_rep::tree_constant_rep (ComplexDiagMatrix& d) +{ + if (d.rows () == 1 && d.columns () == 1) + { + complex_scalar = new Complex (d.elem (0, 0)); + type_tag = complex_scalar_constant; + } + else + { + complex_matrix = new ComplexMatrix (d); + type_tag = complex_matrix_constant; + } +} + +tree_constant_rep::tree_constant_rep (ComplexRowVector& v, + int prefer_column_vector) +{ + int len = v.capacity (); + if (len == 1) + { + complex_scalar = new Complex (v.elem (0)); + type_tag = complex_scalar_constant; + } + else + { + if (prefer_column_vector) + { + ComplexMatrix m (len, 1); + for (int i = 0; i < len; i++) + m.elem (i, 0) = v.elem (i); + complex_matrix = new ComplexMatrix (m); + type_tag = complex_matrix_constant; + } + else + { + ComplexMatrix m (1, len); + for (int i = 0; i < len; i++) + m.elem (0, i) = v.elem (i); + complex_matrix = new ComplexMatrix (m); + type_tag = complex_matrix_constant; + } + } +} + +tree_constant_rep::tree_constant_rep (ComplexColumnVector& v) +{ + int len = v.capacity (); + if (len == 1) + { + complex_scalar = new Complex (v.elem (0)); + type_tag = complex_scalar_constant; + } + else + { + if (user_pref.prefer_column_vectors) + { + ComplexMatrix m (len, 1); + for (int i = 0; i < len; i++) + m.elem (i, 0) = v.elem (i); + complex_matrix = new ComplexMatrix (m); + type_tag = complex_matrix_constant; + } + else + { + ComplexMatrix m (1, len); + for (int i = 0; i < len; i++) + m.elem (0, i) = v.elem (i); + complex_matrix = new ComplexMatrix (m); + type_tag = complex_matrix_constant; + } + } +} + +tree_constant_rep::tree_constant_rep (ComplexColumnVector& v, + int prefer_column_vector) +{ + int len = v.capacity (); + if (len == 1) + { + complex_scalar = new Complex (v.elem (0)); + type_tag = complex_scalar_constant; + } + else + { + if (prefer_column_vector) + { + ComplexMatrix m (len, 1); + for (int i = 0; i < len; i++) + m.elem (i, 0) = v.elem (i); + complex_matrix = new ComplexMatrix (m); + type_tag = complex_matrix_constant; + } + else + { + ComplexMatrix m (1, len); + for (int i = 0; i < len; i++) + m.elem (0, i) = v.elem (i); + complex_matrix = new ComplexMatrix (m); + type_tag = complex_matrix_constant; + } + } +} + +tree_constant_rep::tree_constant_rep (const char *s) +{ + string = strsave (s); + type_tag = string_constant; +} + +tree_constant_rep::tree_constant_rep (String& s) +{ + string = strsave (s); + type_tag = string_constant; +} + +tree_constant_rep::tree_constant_rep (double b, double l, double i) +{ + range = new Range (b, l, i); + int nel = range->nelem (); + if (nel < 0) + { + if (nel == -1) + error ("number of elements in range exceeds INT_MAX"); + else + error ("invalid range"); + + jump_to_top_level (); + } + else if (nel > 1) + type_tag = range_constant; + else + { + delete range; + if (nel == 1) + { + scalar = b; + type_tag = scalar_constant; + } + else if (nel == 0) + { + matrix = new Matrix (); + type_tag = matrix_constant; + } + else + panic_impossible (); + } +} + +tree_constant_rep::tree_constant_rep (Range& r) +{ + if (r.nelem () > 1) + { + range = new Range (r); + type_tag = range_constant; + } + else if (r.nelem () == 1) + { + scalar = r.base (); + type_tag = scalar_constant; + } + else if (r.nelem () == 0) + { + matrix = new Matrix (); + type_tag = matrix_constant; + } + else + panic_impossible (); +} + +tree_constant_rep::tree_constant_rep (tree_constant_rep::constant_type t) +{ + assert (t == magic_colon); + + type_tag = magic_colon; +} + +tree_constant_rep::tree_constant_rep (tree_constant_rep& t) +{ + type_tag = t.type_tag; + + switch (t.type_tag) + { + case unknown_constant: + break; + case scalar_constant: + scalar = t.scalar; + break; + case matrix_constant: + matrix = new Matrix (*(t.matrix)); + break; + case string_constant: + string = strsave (t.string); + break; + case complex_matrix_constant: + complex_matrix = new ComplexMatrix (*(t.complex_matrix)); + break; + case complex_scalar_constant: + complex_scalar = new Complex (*(t.complex_scalar)); + break; + case range_constant: + range = new Range (*(t.range)); + break; + case magic_colon: + break; + default: + panic_impossible (); + break; + } +} + +tree_constant_rep::~tree_constant_rep (void) +{ + switch (type_tag) + { + case unknown_constant: + break; + case scalar_constant: + break; + case matrix_constant: + delete matrix; + break; + case complex_scalar_constant: + delete complex_scalar; + break; + case complex_matrix_constant: + delete complex_matrix; + break; + case string_constant: + delete [] string; + break; + case range_constant: + delete range; + break; + case magic_colon: + break; + default: + panic_impossible (); + break; + } +} + +#if defined (MDEBUG) +void * +tree_constant_rep::operator new (size_t size) +{ + tree_constant_rep *p = ::new tree_constant_rep; + cerr << "tree_constant_rep::new(): " << p << "\n"; + return p; +} + +void +tree_constant_rep::operator delete (void *p, size_t size) +{ + cerr << "tree_constant_rep::delete(): " << p << "\n"; + ::delete p; +} +#endif + +void +tree_constant_rep::resize (int i, int j) +{ + switch (type_tag) + { + case matrix_constant: + matrix->resize (i, j); + break; + case complex_matrix_constant: + complex_matrix->resize (i, j); + break; + default: + panic_impossible (); + break; + } +} + +void +tree_constant_rep::resize (int i, int j, double val) +{ + switch (type_tag) + { + case matrix_constant: + matrix->resize (i, j, val); + break; + case complex_matrix_constant: + complex_matrix->resize (i, j, val); + break; + default: + panic_impossible (); + break; + } +} + +void +tree_constant_rep::maybe_resize (int i, int j) +{ + int nr = rows (); + int nc = columns (); + + i++; + j++; + + assert (i > 0 && j > 0); + + if (i > nr || j > nc) + { + if (user_pref.resize_on_range_error) + resize (MAX (i, nr), MAX (j, nc), 0.0); + else + { + if (i > nr) + message ((char *) NULL, + "row index = %d exceeds max row dimension = %d", i, nr); + if (j > nc) + message ((char *) NULL, + "column index = %d exceeds max column dimension = %d", + j, nc); + + jump_to_top_level (); + } + } +} + +void +tree_constant_rep::maybe_resize (int i, force_orient f_orient = no_orient) +{ + int nr = rows (); + int nc = columns (); + + i++; + + assert (i > 0 && (nr <= 1 || nc <= 1)); + + if (nr <= 1 && nc <= 1 && i >= 1) + { + if (user_pref.resize_on_range_error) + { + if (f_orient == row_orient) + resize (1, i, 0.0); + else if (f_orient == column_orient) + resize (i, 1, 0.0); + else if (user_pref.prefer_column_vectors) + resize (i, 1, 0.0); + else + resize (1, i, 0.0); + } + else + { + message ((char *) NULL, + "matrix index = %d exceeds max dimension = %d", i, nc); + jump_to_top_level (); + } + } + else if (nr == 1 && i > nc) + { + if (user_pref.resize_on_range_error) + resize (1, i, 0.0); + else + { + message ((char *) NULL, + "matrix index = %d exceeds max dimension = %d", i, nc); + jump_to_top_level (); + } + } + else if (nc == 1 && i > nr) + { + if (user_pref.resize_on_range_error) + resize (i, 1, 0.0); + else + { + message ((char *) NULL, + "matrix index = %d exceeds max dimension = ", i, nc); + jump_to_top_level (); + } + } +} + +double +tree_constant_rep::to_scalar (void) +{ + tree_constant tmp = make_numeric (); + + double retval = 0.0; + + switch (tmp.const_type ()) + { + case tree_constant_rep::scalar_constant: + case tree_constant_rep::complex_scalar_constant: + retval = tmp.double_value (); + break; + case tree_constant_rep::matrix_constant: + if (user_pref.do_fortran_indexing) + { + Matrix m = tmp.matrix_value (); + retval = m (0, 0); + } + break; + case tree_constant_rep::complex_matrix_constant: + if (user_pref.do_fortran_indexing) + { + int flag = user_pref.ok_to_lose_imaginary_part; + if (flag == -1) + warning ("implicit conversion of complex value to real value"); + + if (flag != 0) + { + ComplexMatrix m = tmp.complex_matrix_value (); + return real (m (0, 0)); + } + else + jump_to_top_level (); + } + else + { + error ("complex matrix used in invalid context"); + jump_to_top_level (); + } + break; + default: + break; + } + return retval; +} + +ColumnVector +tree_constant_rep::to_vector (void) +{ + tree_constant tmp = make_numeric (); + + ColumnVector retval; + + switch (tmp.const_type ()) + { + case tree_constant_rep::scalar_constant: + case tree_constant_rep::complex_scalar_constant: + retval.resize (1); + retval.elem (0) = tmp.double_value (); + break; + case tree_constant_rep::complex_matrix_constant: + case tree_constant_rep::matrix_constant: + { + Matrix m = tmp.matrix_value (); + int nr = m.rows (); + int nc = m.columns (); + if (nr == 1) + { + retval.resize (nc); + for (int i = 0; i < nc; i++) + retval.elem (i) = m (0, i); + } + else if (nc == 1) + { + retval.resize (nr); + for (int i = 0; i < nr; i++) + retval.elem (i) = m.elem (i, 0); + } + } + break; + default: + panic_impossible (); + break; + } + return retval; +} + +Matrix +tree_constant_rep::to_matrix (void) +{ + tree_constant tmp = make_numeric (); + + Matrix retval; + + switch (tmp.const_type ()) + { + case tree_constant_rep::scalar_constant: + retval.resize (1, 1); + retval.elem (0, 0) = tmp.double_value (); + break; + case tree_constant_rep::matrix_constant: + retval = tmp.matrix_value (); + break; + default: + break; + } + return retval; +} + +tree_constant_rep::constant_type +tree_constant_rep::force_numeric (int force_str_conv = 0) +{ + switch (type_tag) + { + case scalar_constant: + case matrix_constant: + case complex_scalar_constant: + case complex_matrix_constant: + break; + case string_constant: + { + if (! force_str_conv && ! user_pref.implicit_str_to_num_ok) + { + error ("failed to convert `%s' to a numeric type -- default\ + conversion turned off", string); +// Abort! + jump_to_top_level (); + } + + int len = strlen (string); + if (len > 1) + { + type_tag = matrix_constant; + Matrix *tm = new Matrix (1, len); + for (int i = 0; i < len; i++) + tm->elem (0, i) = toascii ((int) string[i]); + matrix = tm; + } + else if (len == 1) + { + type_tag = scalar_constant; + scalar = toascii ((int) string[0]); + } + } + break; + case range_constant: + { + int len = range->nelem (); + if (len > 1) + { + type_tag = matrix_constant; + Matrix *tm = new Matrix (1, len); + double b = range->base (); + double increment = range->inc (); + for (int i = 0; i < len; i++) + tm->elem (0, i) = b + i * increment; + matrix = tm; + } + else if (len == 1) + { + type_tag = scalar_constant; + scalar = range->base (); + } + } + break; + case magic_colon: + default: + panic_impossible (); + break; + } + return type_tag; +} + +tree_constant +tree_constant_rep::make_numeric (int force_str_conv = 0) +{ + tree_constant retval; + switch (type_tag) + { + case scalar_constant: + retval = tree_constant (scalar); + break; + case matrix_constant: + retval = tree_constant (*matrix); + break; + case complex_scalar_constant: + retval = tree_constant (*complex_scalar); + break; + case complex_matrix_constant: + retval = tree_constant (*complex_matrix); + break; + case string_constant: + retval = tree_constant (string); + retval.force_numeric (force_str_conv); + break; + case range_constant: + retval = tree_constant (*range); + retval.force_numeric (force_str_conv); + break; + case magic_colon: + default: + panic_impossible (); + break; + } + return retval; +} + +tree_constant +do_binary_op (tree_constant& a, tree_constant& b, tree::expression_type t) +{ + int first_empty = (a.rows () == 0 || a.columns () == 0); + int second_empty = (b.rows () == 0 || b.columns () == 0); + + if (first_empty || second_empty) + { + int flag = user_pref.propagate_empty_matrices; + if (flag < 0) + warning ("binary operation on empty matrix"); + else if (flag == 0) + { + error ("invalid binary operation on empty matrix"); + jump_to_top_level (); + } + } + + tree_constant tmp_a = a.make_numeric (); + tree_constant tmp_b = b.make_numeric (); + + tree_constant_rep::constant_type a_type = tmp_a.const_type (); + tree_constant_rep::constant_type b_type = tmp_b.const_type (); + + double d1, d2; + Matrix m1, m2; + Complex c1, c2; + ComplexMatrix cm1, cm2; + + tree_constant ans; + + switch (a_type) + { + case tree_constant_rep::scalar_constant: + d1 = tmp_a.double_value (); + switch (b_type) + { + case tree_constant_rep::scalar_constant: + d2 = tmp_b.double_value (); + ans = do_binary_op (d1, d2, t); + break; + case tree_constant_rep::matrix_constant: + m2 = tmp_b.matrix_value (); + ans = do_binary_op (d1, m2, t); + break; + case tree_constant_rep::complex_scalar_constant: + c2 = tmp_b.complex_value (); + ans = do_binary_op (d1, c2, t); + break; + case tree_constant_rep::complex_matrix_constant: + cm2 = tmp_b.complex_matrix_value (); + ans = do_binary_op (d1, cm2, t); + break; + case tree_constant_rep::magic_colon: + default: + panic_impossible (); + break; + } + break; + case tree_constant_rep::matrix_constant: + m1 = tmp_a.matrix_value (); + switch (b_type) + { + case tree_constant_rep::scalar_constant: + d2 = tmp_b.double_value (); + ans = do_binary_op (m1, d2, t); + break; + case tree_constant_rep::matrix_constant: + m2 = tmp_b.matrix_value (); + ans = do_binary_op (m1, m2, t); + break; + case tree_constant_rep::complex_scalar_constant: + c2 = tmp_b.complex_value (); + ans = do_binary_op (m1, c2, t); + break; + case tree_constant_rep::complex_matrix_constant: + cm2 = tmp_b.complex_matrix_value (); + ans = do_binary_op (m1, cm2, t); + break; + case tree_constant_rep::magic_colon: + default: + panic_impossible (); + break; + } + break; + case tree_constant_rep::complex_scalar_constant: + c1 = tmp_a.complex_value (); + switch (b_type) + { + case tree_constant_rep::scalar_constant: + d2 = tmp_b.double_value (); + ans = do_binary_op (c1, d2, t); + break; + case tree_constant_rep::matrix_constant: + m2 = tmp_b.matrix_value (); + ans = do_binary_op (c1, m2, t); + break; + case tree_constant_rep::complex_scalar_constant: + c2 = tmp_b.complex_value (); + ans = do_binary_op (c1, c2, t); + break; + case tree_constant_rep::complex_matrix_constant: + cm2 = tmp_b.complex_matrix_value (); + ans = do_binary_op (c1, cm2, t); + break; + case tree_constant_rep::magic_colon: + default: + panic_impossible (); + break; + } + break; + case tree_constant_rep::complex_matrix_constant: + cm1 = tmp_a.complex_matrix_value (); + switch (b_type) + { + case tree_constant_rep::scalar_constant: + d2 = tmp_b.double_value (); + ans = do_binary_op (cm1, d2, t); + break; + case tree_constant_rep::matrix_constant: + m2 = tmp_b.matrix_value (); + ans = do_binary_op (cm1, m2, t); + break; + case tree_constant_rep::complex_scalar_constant: + c2 = tmp_b.complex_value (); + ans = do_binary_op (cm1, c2, t); + break; + case tree_constant_rep::complex_matrix_constant: + cm2 = tmp_b.complex_matrix_value (); + ans = do_binary_op (cm1, cm2, t); + break; + case tree_constant_rep::magic_colon: + default: + panic_impossible (); + break; + } + break; + case tree_constant_rep::magic_colon: + default: + panic_impossible (); + break; + } + return ans; +} + +tree_constant +do_unary_op (tree_constant& a, tree::expression_type t) +{ + if (a.rows () == 0 || a.columns () == 0) + { + int flag = user_pref.propagate_empty_matrices; + if (flag < 0) + warning ("unary operation on empty matrix"); + else if (flag == 0) + { + error ("invalid unary operation on empty matrix"); + jump_to_top_level (); + } + } + + tree_constant tmp_a = a.make_numeric (); + + tree_constant ans; + + switch (tmp_a.const_type ()) + { + case tree_constant_rep::scalar_constant: + ans = do_unary_op (tmp_a.double_value (), t); + break; + case tree_constant_rep::matrix_constant: + { + Matrix m = tmp_a.matrix_value (); + ans = do_unary_op (m, t); + } + break; + case tree_constant_rep::complex_scalar_constant: + ans = do_unary_op (tmp_a.complex_value (), t); + break; + case tree_constant_rep::complex_matrix_constant: + { + ComplexMatrix m = tmp_a.complex_matrix_value (); + ans = do_unary_op (m, t); + } + break; + case tree_constant_rep::magic_colon: + default: + panic_impossible (); + break; + } + return ans; +} + +void +tree_constant_rep::bump_value (tree::expression_type etype) +{ + switch (etype) + { + case tree::increment: + switch (type_tag) + { + case scalar_constant: + scalar++; + break; + case matrix_constant: + *matrix = *matrix + 1.0; + break; + case complex_scalar_constant: + *complex_scalar = *complex_scalar + 1.0; + break; + case complex_matrix_constant: + *complex_matrix = *complex_matrix + 1.0; + break; + case string_constant: + error ("string++ and ++string not implemented yet, ok?"); + break; + case range_constant: + range->set_base (range->base () + 1.0); + range->set_limit (range->limit () + 1.0); + break; + case magic_colon: + default: + panic_impossible (); + break; + } + break; + case tree::decrement: + switch (type_tag) + { + case scalar_constant: + scalar--; + break; + case matrix_constant: + *matrix = *matrix - 1.0; + break; + case string_constant: + error ("string-- and -- string not implemented yet, ok?"); + break; + case range_constant: + range->set_base (range->base () - 1.0); + range->set_limit (range->limit () - 1.0); + break; + case magic_colon: + default: + panic_impossible (); + break; + } + break; + default: + panic_impossible (); + break; + } +} + +void +tree_constant_rep::eval (int print) +{ + switch (type_tag) + { + case complex_scalar_constant: + if (imag (*complex_scalar) == 0.0) + { + double d = real (*complex_scalar); + delete complex_scalar; + scalar = d; + type_tag = scalar_constant; + } + break; + case complex_matrix_constant: + if (! any_element_is_complex (*complex_matrix)) + { + Matrix *m = new Matrix (real (*complex_matrix)); + delete complex_matrix; + matrix = m; + type_tag = matrix_constant; + } + break; + case scalar_constant: + case matrix_constant: + case string_constant: + case range_constant: + case magic_colon: + break; + default: + panic_impossible (); + break; + } + + if (print) + { + int nr = rows (); + int nc = columns (); + + ostrstream output_buf; + switch (type_tag) + { + case scalar_constant: + octave_print_internal (output_buf, scalar); + break; + case matrix_constant: + if (nr == 0 || nc == 0) + { + output_buf << "[]"; + if (user_pref.print_empty_dimensions) + output_buf << "(" << nr << "x" << nc << ")"; + output_buf << "\n"; + } + else + octave_print_internal (output_buf, *matrix); + break; + case complex_scalar_constant: + octave_print_internal (output_buf, *complex_scalar); + break; + case complex_matrix_constant: + if (nr == 0 || nc == 0) + { + output_buf << "[]"; + if (user_pref.print_empty_dimensions) + output_buf << "(" << nr << "x" << nc << ")"; + output_buf << "\n"; + } + else + octave_print_internal (output_buf, *complex_matrix); + break; + case string_constant: + output_buf << string << "\n"; + break; + case range_constant: + octave_print_internal (output_buf, *range); + break; + case magic_colon: + default: + panic_impossible (); + break; + } + + output_buf << ends; + maybe_page_output (output_buf); + } +} + +tree_constant * +tree_constant_rep::eval (tree_constant *args, int nargin, int nargout, + int print) +{ + tree_constant *retval = new tree_constant [2]; + switch (type_tag) + { + case complex_scalar_constant: + case scalar_constant: + retval[0] = do_scalar_index (args, nargin); + break; + case complex_matrix_constant: + case matrix_constant: + retval[0] = do_matrix_index (args, nargin); + break; + case string_constant: + gripe_string_invalid (); +// retval[0] = do_string_index (args, nargin); + break; + case magic_colon: + case range_constant: +// This isn\'t great, but it\'s easier than implementing a lot of +// range indexing functions. + force_numeric (); + assert (type_tag != magic_colon && type_tag != range_constant); + return eval (args, nargin, nargout, print); + break; + default: + panic_impossible (); + break; + } + + if (retval[0].is_defined ()) + retval[0].eval (print); + return retval; +} + +int +tree_constant_rep::save (ostream& os, int mark_as_global) +{ + switch (type_tag) + { + case scalar_constant: + case matrix_constant: + case complex_scalar_constant: + case complex_matrix_constant: + case string_constant: + case range_constant: + if (mark_as_global) + os << "# type: global "; + else + os << "# type: "; + break; + case magic_colon: + default: + break; + } + + switch (type_tag) + { + case scalar_constant: + os << "scalar\n" + << scalar << "\n"; + break; + case matrix_constant: + os << "matrix\n" + << "# rows: " << rows () << "\n" + << "# columns: " << columns () << "\n" + << *matrix ; + break; + case complex_scalar_constant: + os << "complex scalar\n" + << *complex_scalar << "\n"; + break; + case complex_matrix_constant: + os << "complex matrix\n" + << "# rows: " << rows () << "\n" + << "# columns: " << columns () << "\n" + << *complex_matrix ; + break; + case string_constant: + os << "string\n" + << "# length: " << strlen (string) << "\n" + << string << "\n"; + break; + case range_constant: + { + os << "range\n" + << "# base, limit, increment\n" + << range->base () << " " + << range->limit () << " " + << range->inc () << "\n"; + } + break; + case magic_colon: + default: + panic_impossible (); + break; + } +// Really want to return 1 only if write is successful. + return 1; +} + +int +tree_constant_rep::save_three_d (ostream& os, int parametric) +{ + int nr = rows (); + int nc = columns (); + + switch (type_tag) + { + case matrix_constant: + os << "# 3D data...\n" + << "# type: matrix\n" + << "# total rows: " << nr << "\n" + << "# total columns: " << nc << "\n"; + + if (parametric) + { + int extras = nc % 3; + if (extras) + warning ("ignoring last %d columns", extras); + + for (int i = 0; i < nc-extras; i += 3) + { + os << matrix->extract (0, i, nr-1, i+2); + if (i+3 < nc-extras) + os << "\n"; + } + } + else + { + for (int i = 0; i < nc; i++) + { + os << matrix->extract (0, i, nr-1, i); + if (i+1 < nc) + os << "\n"; + } + } + break; + default: + error ("for now, I can only save real matrices in 3D format"); + return 0; + break; + } +// Really want to return 1 only if write is successful. + return 1; +} + +int +tree_constant_rep::load (istream& is) +{ + int is_global = 0; + + type_tag = unknown_constant; + +// Look for type keyword + char tag [128]; + if (extract_keyword (is, "type", tag)) + { + if (tag != (char *) NULL && *tag != '\0') + { + char *ptr = strchr (tag, ' '); + if (ptr != (char *) NULL) + { + *ptr = '\0'; + is_global = (strncmp (tag, "global", 6) == 0); + *ptr = ' '; + ptr++; + } + else + ptr = &tag[0]; + + if (strncmp (ptr, "scalar", 6) == 0) + type_tag = load (is, scalar_constant); + else if (strncmp (ptr, "matrix", 6) == 0) + type_tag = load (is, matrix_constant); + else if (strncmp (ptr, "complex scalar", 14) == 0) + type_tag = load (is, complex_scalar_constant); + else if (strncmp (ptr, "complex matrix", 14) == 0) + type_tag = load (is, complex_matrix_constant); + else if (strncmp (ptr, "string", 6) == 0) + type_tag = load (is, string_constant); + else if (strncmp (ptr, "range", 5) == 0) + type_tag = load (is, range_constant); + else + error ("unknown constant type `%s'", tag); + } + else + error ("failed to extract keyword specifying value type"); + } + + return is_global; +} + +tree_constant_rep::constant_type +tree_constant_rep::load (istream& is, tree_constant_rep::constant_type t) +{ + tree_constant_rep::constant_type status = unknown_constant; + + switch (t) + { + case scalar_constant: + is >> scalar; + if (is) + status = scalar_constant; + else + error ("failed to load scalar constant"); + break; + case matrix_constant: + { + int nr = 0, nc = 0; + + if (extract_keyword (is, "rows", nr) && nr > 0 + && extract_keyword (is, "columns", nc) && nc > 0) + { + matrix = new Matrix (nr, nc); + is >> *matrix; + if (is) + status = matrix_constant; + else + error ("failed to load matrix constant"); + } + else + error ("failed to extract number of rows and columns"); + } + break; + case complex_scalar_constant: + is >> *complex_scalar; + if (is) + status = complex_scalar_constant; + else + error ("failed to load complex scalar constant"); + break; + case complex_matrix_constant: + { + int nr = 0, nc = 0; + + if (extract_keyword (is, "rows", nr) && nr > 0 + && extract_keyword (is, "columns", nc) && nc > 0) + { + complex_matrix = new ComplexMatrix (nr, nc); + is >> *complex_matrix; + if (is) + status = complex_matrix_constant; + else + error ("failed to load complex matrix constant"); + } + else + error ("failed to extract number of rows and columns"); + } + break; + case string_constant: + { + int len; + if (extract_keyword (is, "length", len) && len > 0) + { + string = new char [len+1]; + is.get (string, len+1, EOF); + if (is) + status = string_constant; + else + error ("failed to load string constant"); + } + else + error ("failed to extract string length"); + } + break; + case range_constant: + skip_comments (is); + range = new Range (); + is >> *range; + if (is) + status = range_constant; + else + error ("failed to load range constant"); + break; + default: + panic_impossible (); + break; + } + return status; +} + +double +tree_constant_rep::double_value (void) +{ + assert (type_tag == scalar_constant || type_tag == complex_scalar_constant); + + if (type_tag == scalar_constant) + return scalar; + else if (type_tag == complex_scalar_constant) + { + int flag = user_pref.ok_to_lose_imaginary_part; + if (flag == -1) + warning ("implicit conversion of complex value to real value"); + + if (flag != 0) + return real (*complex_scalar); + else + { + error ("implicit conversion of complex value to real value not allowed"); + jump_to_top_level (); + } + } +} + +Matrix +tree_constant_rep::matrix_value (void) +{ + assert (type_tag == matrix_constant || type_tag == complex_matrix_constant); + + if (type_tag == matrix_constant) + return *matrix; + else if (type_tag == complex_matrix_constant) + { + int flag = user_pref.ok_to_lose_imaginary_part; + if (flag == -1) + warning ("implicit conversion of complex matrix to real matrix"); + + if (flag != 0) + return real (*complex_matrix); + else + { + error ("implicit conversion of complex matrix to real matrix not allowed"); + jump_to_top_level (); + } + } +} + +Complex +tree_constant_rep::complex_value (void) +{ + assert (type_tag == complex_scalar_constant); + return *complex_scalar; +} + +ComplexMatrix +tree_constant_rep::complex_matrix_value (void) +{ + assert (type_tag == complex_matrix_constant); + return *complex_matrix; +} + +char * +tree_constant_rep::string_value (void) +{ + assert (type_tag == string_constant); + return string; +} + +Range +tree_constant_rep::range_value (void) +{ + assert (type_tag == range_constant); + return *range; +} + +int +tree_constant_rep::rows (void) +{ + int retval = -1; + switch (type_tag) + { + case scalar_constant: + case complex_scalar_constant: + case string_constant: + case range_constant: + retval = 1; + break; + case matrix_constant: + retval = matrix->rows (); + break; + case complex_matrix_constant: + retval = complex_matrix->rows (); + break; + case magic_colon: + error ("invalid use of colon operator"); + break; + case unknown_constant: + retval = 0; + break; + default: + panic_impossible (); + break; + } + return retval; +} + +int +tree_constant_rep::columns (void) +{ + int retval = -1; + switch (type_tag) + { + case scalar_constant: + case complex_scalar_constant: + retval = 1; + break; + case matrix_constant: + retval = matrix->columns (); + break; + case complex_matrix_constant: + retval = complex_matrix->columns (); + break; + case string_constant: + retval = strlen (string); + break; + case range_constant: + retval = range->nelem (); + break; + case magic_colon: + error ("invalid use of colon operator"); + break; + case unknown_constant: + retval = 0; + break; + default: + panic_impossible (); + break; + } + return retval; +} + +tree_constant +tree_constant_rep::all (void) +{ + if (type_tag == string_constant || type_tag == range_constant) + { + tree_constant tmp = make_numeric (); + return tmp.all (); + } + + tree_constant retval; + switch (type_tag) + { + case scalar_constant: + { + double status = (scalar != 0.0); + retval = tree_constant (status); + } + break; + case matrix_constant: + { + Matrix m = matrix->all (); + retval = tree_constant (m); + } + break; + case complex_scalar_constant: + { + double status = (*complex_scalar != 0.0); + retval = tree_constant (status); + } + break; + case complex_matrix_constant: + { + Matrix m = complex_matrix->all (); + retval = tree_constant (m); + } + break; + case string_constant: + case range_constant: + case magic_colon: + default: + panic_impossible (); + break; + } + return retval; +} + +tree_constant +tree_constant_rep::any (void) +{ + if (type_tag == string_constant || type_tag == range_constant) + { + tree_constant tmp = make_numeric (); + return tmp.any (); + } + + tree_constant retval; + switch (type_tag) + { + case scalar_constant: + { + double status = (scalar != 0.0); + retval = tree_constant (status); + } + break; + case matrix_constant: + { + Matrix m = matrix->any (); + retval = tree_constant (m); + } + break; + case complex_scalar_constant: + { + double status = (*complex_scalar != 0.0); + retval = tree_constant (status); + } + break; + case complex_matrix_constant: + { + Matrix m = complex_matrix->any (); + retval = tree_constant (m); + } + break; + case string_constant: + case range_constant: + case magic_colon: + default: + panic_impossible (); + break; + } + return retval; +} + +tree_constant +tree_constant_rep::isstr (void) +{ + double status = 0.0; + if (const_type () == string_constant) + status = 1.0; + tree_constant retval (status); + return retval; +} + +tree_constant +tree_constant_rep::convert_to_str (void) +{ + tree_constant retval; + + switch (type_tag) + { + case complex_scalar_constant: + case scalar_constant: + { + double d = double_value (); + int i = NINT (d); +// Warn about out of range conversions? + char s[2]; + s[0] = (char) i; + retval = tree_constant (s); + } + break; + case complex_matrix_constant: + case matrix_constant: + { + ColumnVector v = to_vector (); + int len = v.length (); + if (len == 0) + error ("can only convert vectors and scalars to strings"); + else + { + char *s = new char [len+1]; + s[len] = '\0'; + for (int i = 0; i < len; i++) + { + double d = v.elem (i); + int ival = NINT (d); +// Warn about out of range conversions? + s[i] = (char) ival; + } + retval = tree_constant (s); + delete [] s; + } + } + break; + case range_constant: + { + Range r = range_value (); + double b = r.base (); + double incr = r.inc (); + int nel = r.nelem (); + char *s = new char [nel+1]; + s[nel] = '\0'; + for (int i = 0; i < nel; i++) + { + double d = b + i * incr; + int ival = NINT (d); +// Warn about out of range conversions? + s[i] = (char) ival; + } + retval = tree_constant (s); + delete [] s; + } + break; + case string_constant: + retval = tree_constant (*this); + break; + case magic_colon: + default: + panic_impossible (); + break; + } + return retval; +} + +tree_constant +tree_constant_rep::cumprod (void) +{ + if (type_tag == string_constant || type_tag == range_constant) + { + tree_constant tmp = make_numeric (); + return tmp.cumprod (); + } + + tree_constant retval; + switch (type_tag) + { + case scalar_constant: + retval = tree_constant (scalar); + break; + case matrix_constant: + { + Matrix m = matrix->cumprod (); + retval = tree_constant (m); + } + break; + case complex_scalar_constant: + retval = tree_constant (*complex_scalar); + break; + case complex_matrix_constant: + { + ComplexMatrix m = complex_matrix->cumprod (); + retval = tree_constant (m); + } + break; + case string_constant: + case range_constant: + case magic_colon: + default: + panic_impossible (); + break; + } + return retval; +} + +tree_constant +tree_constant_rep::cumsum (void) +{ + if (type_tag == string_constant || type_tag == range_constant) + { + tree_constant tmp = make_numeric (); + return tmp.cumsum (); + } + + tree_constant retval; + switch (type_tag) + { + case scalar_constant: + retval = tree_constant (scalar); + break; + case matrix_constant: + { + Matrix m = matrix->cumsum (); + retval = tree_constant (m); + } + break; + case complex_scalar_constant: + retval = tree_constant (*complex_scalar); + break; + case complex_matrix_constant: + { + ComplexMatrix m = complex_matrix->cumsum (); + retval = tree_constant (m); + } + break; + case string_constant: + case range_constant: + case magic_colon: + default: + panic_impossible (); + break; + } + return retval; +} + +tree_constant +tree_constant_rep::prod (void) +{ + if (type_tag == string_constant || type_tag == range_constant) + { + tree_constant tmp = make_numeric (); + return tmp.prod (); + } + + tree_constant retval; + switch (type_tag) + { + case scalar_constant: + retval = tree_constant (scalar); + break; + case matrix_constant: + { + Matrix m = matrix->prod (); + retval = tree_constant (m); + } + break; + case complex_scalar_constant: + retval = tree_constant (*complex_scalar); + break; + case complex_matrix_constant: + { + ComplexMatrix m = complex_matrix->prod (); + retval = tree_constant (m); + } + break; + case string_constant: + case range_constant: + case magic_colon: + default: + panic_impossible (); + break; + } + return retval; +} + +tree_constant +tree_constant_rep::sum (void) +{ + if (type_tag == string_constant || type_tag == range_constant) + { + tree_constant tmp = make_numeric (); + return tmp.sum (); + } + + tree_constant retval; + switch (type_tag) + { + case scalar_constant: + retval = tree_constant (scalar); + break; + case matrix_constant: + { + Matrix m = matrix->sum (); + retval = tree_constant (m); + } + break; + case complex_scalar_constant: + retval = tree_constant (*complex_scalar); + break; + case complex_matrix_constant: + { + ComplexMatrix m = complex_matrix->sum (); + retval = tree_constant (m); + } + break; + case string_constant: + case range_constant: + case magic_colon: + default: + panic_impossible (); + break; + } + return retval; +} + +tree_constant +tree_constant_rep::sumsq (void) +{ + if (type_tag == string_constant || type_tag == range_constant) + { + tree_constant tmp = make_numeric (); + return tmp.sumsq (); + } + + tree_constant retval; + switch (type_tag) + { + case scalar_constant: + retval = tree_constant (scalar * scalar); + break; + case matrix_constant: + { + Matrix m = matrix->sumsq (); + retval = tree_constant (m); + } + break; + case complex_scalar_constant: + { + Complex c (*complex_scalar); + retval = tree_constant (c * c); + } + break; + case complex_matrix_constant: + { + ComplexMatrix m = complex_matrix->sumsq (); + retval = tree_constant (m); + } + break; + case string_constant: + case range_constant: + case magic_colon: + default: + panic_impossible (); + break; + } + return retval; +} + +static tree_constant +make_diag (Matrix& v, int k) +{ + int nr = v.rows (); + int nc = v.columns (); + assert (nc == 1 || nr == 1); + + tree_constant retval; + + int roff = 0; + int coff = 0; + if (k > 0) + { + roff = 0; + coff = k; + } + else if (k < 0) + { + roff = -k; + coff = 0; + } + + if (nr == 1) + { + int n = nc + ABS (k); + Matrix m (n, n, 0.0); + for (int i = 0; i < nc; i++) + m.elem (i+roff, i+coff) = v.elem (0, i); + retval = tree_constant (m); + } + else + { + int n = nr + ABS (k); + Matrix m (n, n, 0.0); + for (int i = 0; i < nr; i++) + m.elem (i+roff, i+coff) = v.elem (i, 0); + retval = tree_constant (m); + } + + return retval; +} + +static tree_constant +make_diag (ComplexMatrix& v, int k) +{ + int nr = v.rows (); + int nc = v.columns (); + assert (nc == 1 || nr == 1); + + tree_constant retval; + + int roff = 0; + int coff = 0; + if (k > 0) + { + roff = 0; + coff = k; + } + else if (k < 0) + { + roff = -k; + coff = 0; + } + + if (nr == 1) + { + int n = nc + ABS (k); + ComplexMatrix m (n, n, 0.0); + for (int i = 0; i < nc; i++) + m.elem (i+roff, i+coff) = v.elem (0, i); + retval = tree_constant (m); + } + else + { + int n = nr + ABS (k); + ComplexMatrix m (n, n, 0.0); + for (int i = 0; i < nr; i++) + m.elem (i+roff, i+coff) = v.elem (i, 0); + retval = tree_constant (m); + } + + return retval; +} + +tree_constant +tree_constant_rep::diag (void) +{ + if (type_tag == string_constant || type_tag == range_constant) + { + tree_constant tmp = make_numeric (); + return tmp.diag (); + } + + tree_constant retval; + switch (type_tag) + { + case scalar_constant: + retval = tree_constant (scalar); + break; + case matrix_constant: + { + int nr = rows (); + int nc = columns (); + if (nr == 1 || nc == 1) + retval = make_diag (matrix_value (), 0); + else + { + ColumnVector v = matrix->diag (); + if (v.capacity () > 0) + retval = tree_constant (v); + } + } + break; + case complex_scalar_constant: + retval = tree_constant (*complex_scalar); + break; + case complex_matrix_constant: + { + int nr = rows (); + int nc = columns (); + if (nr == 1 || nc == 1) + retval = make_diag (complex_matrix_value (), 0); + else + { + ComplexColumnVector v = complex_matrix->diag (); + if (v.capacity () > 0) + retval = tree_constant (v); + } + } + break; + case string_constant: + case range_constant: + case magic_colon: + default: + panic_impossible (); + break; + } + return retval; +} + +tree_constant +tree_constant_rep::diag (tree_constant& a) +{ + if (type_tag == string_constant || type_tag == range_constant) + { + tree_constant tmp = make_numeric (); + return tmp.diag (a); + } + + tree_constant tmp_a = a.make_numeric (); + + tree_constant_rep::constant_type a_type = tmp_a.const_type (); + + tree_constant retval; + + switch (type_tag) + { + case scalar_constant: + if (a_type == scalar_constant) + { + int k = NINT (tmp_a.double_value ()); + int n = ABS (k) + 1; + if (k == 0) + retval = tree_constant (scalar); + else if (k > 0) + { + Matrix m (n, n, 0.0); + m.elem (0, k) = scalar; + retval = tree_constant (m); + } + else if (k < 0) + { + Matrix m (n, n, 0.0); + m.elem (-k, 0) = scalar; + retval = tree_constant (m); + } + } + break; + case matrix_constant: + if (a_type == scalar_constant) + { + int k = NINT (tmp_a.double_value ()); + int nr = rows (); + int nc = columns (); + if (nr == 1 || nc == 1) + retval = make_diag (matrix_value (), k); + else + { + ColumnVector d = matrix->diag (k); + retval = tree_constant (d); + } + } + else + message ("diag", "invalid second argument"); + + break; + case complex_scalar_constant: + if (a_type == scalar_constant) + { + int k = NINT (tmp_a.double_value ()); + int n = ABS (k) + 1; + if (k == 0) + retval = tree_constant (*complex_scalar); + else if (k > 0) + { + ComplexMatrix m (n, n, 0.0); + m.elem (0, k) = *complex_scalar; + retval = tree_constant (m); + } + else if (k < 0) + { + ComplexMatrix m (n, n, 0.0); + m.elem (-k, 0) = *complex_scalar; + retval = tree_constant (m); + } + } + break; + case complex_matrix_constant: + if (a_type == scalar_constant) + { + int k = NINT (tmp_a.double_value ()); + int nr = rows (); + int nc = columns (); + if (nr == 1 || nc == 1) + retval = make_diag (complex_matrix_value (), k); + else + { + ComplexColumnVector d = complex_matrix->diag (k); + retval = tree_constant (d); + } + } + else + message ("diag", "invalid second argument"); + + break; + case string_constant: + case range_constant: + case magic_colon: + default: + panic_impossible (); + break; + } + return retval; +} + +void +tree_constant_rep::print_if_string (ostream& os, int warn) +{ + if (type_tag == string_constant) + os << string << "\n"; + else if (warn) + warning ("expecting string, found numeric constant"); +} + +tree_constant +tree_constant_rep::mapper (Mapper_fcn& m_fcn, int print) +{ + tree_constant retval; + + if (type_tag == string_constant || type_tag == range_constant) + { + tree_constant tmp = make_numeric (); + return tmp.mapper (m_fcn, print); + } + + switch (type_tag) + { + case scalar_constant: + if (m_fcn.neg_arg_complex && scalar < 0.0) + { + if (m_fcn.c_c_mapper != NULL) + { + Complex c = m_fcn.c_c_mapper (Complex (scalar)); + retval = tree_constant (c); + } + else + panic_impossible (); + } + else + { + if (m_fcn.d_d_mapper != NULL) + { + double d = m_fcn.d_d_mapper (scalar); + retval = tree_constant (d); + } + else + panic_impossible (); + } + break; + case matrix_constant: + if (m_fcn.neg_arg_complex && any_element_is_negative (*matrix)) + { + if (m_fcn.c_c_mapper != NULL) + { + ComplexMatrix cm = map (m_fcn.c_c_mapper, + ComplexMatrix (*matrix)); + retval = tree_constant (cm); + } + else + panic_impossible (); + } + else + { + if (m_fcn.d_d_mapper != NULL) + { + Matrix m = map (m_fcn.d_d_mapper, *matrix); + retval = tree_constant (m); + } + else + panic_impossible (); + } + break; + case complex_scalar_constant: + if (m_fcn.d_c_mapper != NULL) + { + double d; + d = m_fcn.d_c_mapper (*complex_scalar); + retval = tree_constant (d); + } + else if (m_fcn.c_c_mapper != NULL) + { + Complex c; + c = m_fcn.c_c_mapper (*complex_scalar); + retval = tree_constant (c); + } + else + panic_impossible (); + break; + case complex_matrix_constant: + if (m_fcn.d_c_mapper != NULL) + { + Matrix m; + m = map (m_fcn.d_c_mapper, *complex_matrix); + retval = tree_constant (m); + } + else if (m_fcn.c_c_mapper != NULL) + { + ComplexMatrix cm; + cm = map (m_fcn.c_c_mapper, *complex_matrix); + retval = tree_constant (cm); + } + else + panic_impossible (); + break; + case string_constant: + case range_constant: + case magic_colon: + default: + panic_impossible (); + break; + } + + if (retval.is_defined ()) + return retval.eval (print); + else + return retval; +} + +tree_constant::~tree_constant (void) +{ +#if defined (MDEBUG) + cerr << "~tree_constant: rep: " << rep + << " rep->count: " << rep->count << "\n"; +#endif + + if (--rep->count <= 0) + { + delete rep; + rep = (tree_constant_rep *) NULL; + } +} + +#if defined (MDEBUG) +void * +tree_constant::operator new (size_t size) +{ + tree_constant *p = ::new tree_constant; + cerr << "tree_constant::new(): " << p << "\n"; + return p; +} + +void +tree_constant::operator delete (void *p, size_t size) +{ + cerr << "tree_constant::delete(): " << p << "\n"; + ::delete p; +} +#endif + +/* +;;; Local Variables: *** +;;; mode: C++ *** +;;; page-delimiter: "^/\\*" *** +;;; End: *** +*/
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/pt-const.h Sun Aug 08 01:13:40 1993 +0000 @@ -0,0 +1,793 @@ +// The rest of the tree classes. -*- C++ -*- +/* + +Copyright (C) 1992, 1993 John W. Eaton + +This file is part of Octave. + +Octave is free software; you can redistribute it and/or modify it +under the terms of the GNU General Public License as published by the +Free Software Foundation; either version 2, or (at your option) any +later version. + +Octave is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +for more details. + +You should have received a copy of the GNU General Public License +along with Octave; see the file COPYING. If not, write to the Free +Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. + +*/ + +#if !defined (_tree_const_h) +#define _tree_const_h 1 + +#ifdef __GNUG__ +#pragma interface +#endif + +#include <stdlib.h> +#include <String.h> + +#include "Range.h" +#include "builtins.h" +#include "Matrix.h" +#include "idx-vector.h" +#include "tree-base.h" + +/* + * How about a few macros? + */ + +#ifndef MAX +#define MAX(a,b) ((a) > (b) ? (a) : (b)) +#endif + +#ifndef MIN +#define MIN(a,b) ((a) < (b) ? (a) : (b)) +#endif + +#ifndef ABS +#define ABS(x) (((x) < 0) ? (-x) : (x)) +#endif + +#ifndef NULL_TREE +#define NULL_TREE (tree *)NULL +#endif + +#ifndef NULL_TREE_CONST +#define NULL_TREE_CONST (tree_constant *)NULL +#endif + +/* + * The following are used by some of the functions in the + * tree_constant_rep class that must deal with real and complex + * matrices. This was not done with overloaded or virtual functions + * from the Matrix class because there is no clean way to do that -- + * the necessary functions (like elem) need to return values of + * different types... + */ + +// Given a tree_constant, and the names to be used for the real and +// complex matrix and their dimensions, declare a real or complex +// matrix, and initialize it from the tree_constant. Note that m, cm, +// nr, and nc must not be previously declared, and they must not be +// expressions. Since only one of the matrices will be defined after +// this macro is used, only one set of dimesions is declared. + +// This macro only makes sense inside a friend or member function of +// the tree_constant_rep class + +#define REP_RHS_MATRIX(tc,m,cm,nr,nc) \ + int nr, nc; \ + Matrix m; \ + ComplexMatrix cm; \ + if ((tc).const_type () == tree_constant_rep::complex_matrix_constant) \ + { \ + cm = (tc).complex_matrix_value (); \ + nr = (cm).rows (); \ + nc = (cm).columns (); \ + } \ + else \ + { \ + m = (tc).matrix_value (); \ + nr = (m).rows (); \ + nc = (m).columns (); \ + } + +// Assign a real or complex value to a tree_constant. +// +// This macro only makes sense inside a friend or member function of +// the tree_constant_rep class. + +#define REP_ELEM_ASSIGN(i,j,rval,cval,real_type) \ + do \ + { \ + if (type_tag == tree_constant_rep::matrix_constant) \ + { \ + if (real_type) \ + matrix->elem ((i), (j)) = (rval); \ + else \ + abort (); \ + } \ + else \ + { \ + if (real_type) \ + complex_matrix->elem ((i), (j)) = (rval); \ + else \ + complex_matrix->elem ((i), (j)) = (cval); \ + } \ + } \ + while (0) + +// Given a real and complex matrix and row and column dimensions, +// declare both and size one of them. Only one of the matrices should +// be used after this macro has been used. + +// This macro only makes sense inside a friend or member function of +// the tree_constant_rep class. + +#define CRMATRIX(m,cm,nr,nc) \ + Matrix m; \ + ComplexMatrix cm; \ + if (type_tag == tree_constant_rep::matrix_constant) \ + { \ + (m).resize ((nr), (nc)); \ + } \ + else if (type_tag == complex_matrix_constant) \ + { \ + (cm).resize ((nr), (nc)); \ + } \ + else \ + { \ + abort (); \ + } + +// Assign a real or complex matrix to a tree constant. + +// This macro only makes sense inside a friend or member function of +// the tree_constant_rep class. + +#define ASSIGN_CRMATRIX_TO(tc,m,cm) \ + do \ + { \ + if (type_tag == matrix_constant) \ + tc = tree_constant (m); \ + else \ + tc = tree_constant (cm); \ + } \ + while (0) + +// Assign an element of this tree_constant_rep's real or complex +// matrix to another real or complex matrix. + +// This macro only makes sense inside a friend or member function of +// the tree_constant_rep class. + +#define CRMATRIX_ASSIGN_REP_ELEM(m,cm,i1,j1,i2,j2) \ + do \ + { \ + if (type_tag == matrix_constant) \ + (m).elem ((i1), (j1)) = matrix->elem ((i2), (j2)); \ + else \ + (cm).elem ((i1), (j1)) = complex_matrix->elem ((i2), (j2)); \ + } \ + while (0) + +// Assign a value to an element of a real or complex matrix. Assumes +// that the lhs and rhs are either both real or both complex types. + +#define CRMATRIX_ASSIGN_ELEM(m,cm,i,j,rval,cval,real_type) \ + do \ + { \ + if (real_type) \ + (m).elem ((i), (j)) = (rval); \ + else \ + (cm).elem ((i), (j)) = (cval); \ + } \ + while (0) + + +/* + * Forward class declarations. + */ +class tree; +class tree_constant; + +#ifndef TREE_FCN_TYPEDEFS +#define TREE_FCN_TYPEDEFS 1 + +typedef tree_constant (*Text_fcn)(int, char **); +typedef tree_constant* (*General_fcn)(tree_constant *, int, int); + +#endif + +/* + * The actual representation of the tree_constant. + */ +class +tree_constant_rep +{ +friend class tree_constant; + + enum force_orient + { + no_orient, + row_orient, + column_orient, + }; + +public: + enum constant_type + { + unknown_constant, + scalar_constant, + matrix_constant, + complex_scalar_constant, + complex_matrix_constant, + string_constant, + range_constant, + magic_colon, + }; + + tree_constant_rep (void); + + tree_constant_rep (double d); + tree_constant_rep (Matrix& m); + tree_constant_rep (DiagMatrix& d); + tree_constant_rep (RowVector& v); + tree_constant_rep (RowVector& v, int pcv); + tree_constant_rep (ColumnVector& v); + tree_constant_rep (ColumnVector& v, int pcv); + + tree_constant_rep (Complex c); + tree_constant_rep (ComplexMatrix& m); + tree_constant_rep (ComplexDiagMatrix& d); + tree_constant_rep (ComplexRowVector& v); + tree_constant_rep (ComplexRowVector& v, int pcv); + tree_constant_rep (ComplexColumnVector& v); + tree_constant_rep (ComplexColumnVector& v, int pcv); + + tree_constant_rep (const char *s); + tree_constant_rep (String& s); + + tree_constant_rep (double base, double limit, double inc); + tree_constant_rep (Range& r); + + tree_constant_rep (tree_constant_rep::constant_type t); + + tree_constant_rep (tree_constant_rep& t); + + ~tree_constant_rep (void); + +#if defined (MDEBUG) + void *operator new (size_t size); + void operator delete (void *p, size_t size); +#endif + + void resize (int i, int j); + void resize (int i, int j, double val); + + void maybe_resize (int imax, force_orient fo = no_orient); + void maybe_resize (int imax, int jmax); + + int valid_as_scalar_index (void); + + int is_defined (void) + { return type_tag != tree_constant_rep::unknown_constant; } + + int is_undefined (void) + { return type_tag == tree_constant_rep::unknown_constant; } + + int is_string_type (void) + { return type_tag == tree_constant_rep::string_constant; } + + int is_scalar_type (void) + { return type_tag == scalar_constant + || type_tag == complex_scalar_constant; } + + int is_matrix_type (void) + { return type_tag == matrix_constant + || type_tag == complex_matrix_constant; } + + int is_real_type (void) + { return type_tag == scalar_constant + || type_tag == matrix_constant + || type_tag == range_constant; } + + int is_complex_type (void) + { return type_tag == complex_matrix_constant + || type_tag == complex_scalar_constant; } + + + int is_numeric_type (void) + { return type_tag == scalar_constant + || type_tag == matrix_constant + || type_tag == complex_matrix_constant + || type_tag == complex_scalar_constant; } + + int is_numeric_or_range_type (void) + { return type_tag == scalar_constant + || type_tag == matrix_constant + || type_tag == complex_matrix_constant + || type_tag == complex_scalar_constant + || type_tag == range_constant; } + + double to_scalar (void); + ColumnVector to_vector (void); + Matrix to_matrix (void); + + tree_constant_rep::constant_type force_numeric (int force_str_conv = 0); + tree_constant make_numeric (int force_str_conv = 0); + + friend tree_constant + do_binary_op (tree_constant& a, tree_constant& b, tree::expression_type t); + + friend tree_constant + do_unary_op (tree_constant& a, tree::expression_type t); + + void assign (tree_constant& rhs, tree_constant *args, int nargs); + + void do_scalar_assignment + (tree_constant& rhs, tree_constant *args, int nargin); + + void do_matrix_assignment + (tree_constant& rhs, tree_constant *args, int nargin); + + void do_matrix_assignment + (tree_constant& rhs, tree_constant& i_arg); + + void do_matrix_assignment + (tree_constant& rhs, tree_constant& i_arg, tree_constant& j_arg); + + void fortran_style_matrix_assignment (tree_constant& rhs, + tree_constant& i_arg); + + void fortran_style_matrix_assignment (tree_constant& rhs, constant_type ci); + + void fortran_style_matrix_assignment (tree_constant& rhs, idx_vector& i); + + void vector_assignment (tree_constant& rhs, tree_constant& i_arg); + + void check_vector_assign (int rhs_nr, int rhs_nc, int ilen, char *rm); + + void do_vector_assign (tree_constant& rhs, int i); + void do_vector_assign (tree_constant& rhs, idx_vector& i); + void do_vector_assign (tree_constant& rhs, Range& i, int imax); + + void do_matrix_assignment + (tree_constant& rhs, int i, tree_constant& j_arg); + void do_matrix_assignment + (tree_constant& rhs, idx_vector& i, tree_constant& j_arg); + void do_matrix_assignment + (tree_constant& rhs, Range& i, int imax, tree_constant& j_arg); + void do_matrix_assignment + (tree_constant& rhs, constant_type i, tree_constant& j_arg); + + void do_matrix_assignment (tree_constant& rhs, int i, int j); + void do_matrix_assignment (tree_constant& rhs, int i, idx_vector& jv); + void do_matrix_assignment (tree_constant& rhs, int i, Range& j); + void do_matrix_assignment (tree_constant& rhs, int i, constant_type cj); + + void do_matrix_assignment (tree_constant& rhs, idx_vector& iv, int j); + void do_matrix_assignment (tree_constant& rhs, idx_vector& iv, + idx_vector& jv); + void do_matrix_assignment (tree_constant& rhs, idx_vector& iv, Range& j); + void do_matrix_assignment (tree_constant& rhs, idx_vector& iv, + constant_type j); + + void do_matrix_assignment (tree_constant& rhs, Range& i, int j); + void do_matrix_assignment (tree_constant& rhs, Range& i, idx_vector& jv); + void do_matrix_assignment (tree_constant& rhs, Range& i, Range& j); + void do_matrix_assignment (tree_constant& rhs, Range& i, constant_type j); + + void do_matrix_assignment (tree_constant& rhs, constant_type i, int j); + void do_matrix_assignment (tree_constant& rhs, constant_type i, + idx_vector& jv); + void do_matrix_assignment (tree_constant& rhs, constant_type i, Range& j); + void do_matrix_assignment (tree_constant& rhs, constant_type i, + constant_type j); + + void bump_value (tree::expression_type); + + void eval (int print); + + tree_constant *eval (tree_constant *args, int n_in, int n_out, int print); + + tree_constant do_scalar_index (tree_constant *args, int nargin); + + tree_constant do_matrix_index (tree_constant *args, int nargin); + + tree_constant do_matrix_index (tree_constant& i_arg); + + tree_constant do_matrix_index (tree_constant& i_arg, tree_constant& j_arg); + + tree_constant do_matrix_index (constant_type i); + + tree_constant fortran_style_matrix_index (tree_constant& i_arg); + tree_constant fortran_style_matrix_index (Matrix& mi); + + tree_constant do_vector_index (tree_constant& i_arg); + + tree_constant do_matrix_index (int i, tree_constant& i_arg); + tree_constant do_matrix_index (idx_vector& i, tree_constant& i_arg); + tree_constant do_matrix_index (Range& i, int imax, tree_constant& i_arg); + tree_constant do_matrix_index (constant_type i, tree_constant& i_arg); + + tree_constant do_matrix_index (int i, int j); + tree_constant do_matrix_index (int i, idx_vector& j); + tree_constant do_matrix_index (int i, Range& j); + tree_constant do_matrix_index (int i, constant_type cj); + + tree_constant do_matrix_index (idx_vector& i, int j); + tree_constant do_matrix_index (idx_vector& i, idx_vector& j); + tree_constant do_matrix_index (idx_vector& i, Range& j); + tree_constant do_matrix_index (idx_vector& i, constant_type j); + + tree_constant do_matrix_index (Range& i, int j); + tree_constant do_matrix_index (Range& i, idx_vector& j); + tree_constant do_matrix_index (Range& i, Range& j); + tree_constant do_matrix_index (Range& i, constant_type j); + + tree_constant do_matrix_index (constant_type i, int j); + tree_constant do_matrix_index (constant_type i, idx_vector& j); + tree_constant do_matrix_index (constant_type i, Range& j); + tree_constant do_matrix_index (constant_type i, constant_type j); + + int save (ostream& os, int mark_as_global); + int save_three_d (ostream& os, int parametric); + int load (istream& is); + constant_type load (istream& is, constant_type t); + + double double_value (void); + Matrix matrix_value (void); + Complex complex_value (void); + ComplexMatrix complex_matrix_value (void); + char *string_value (void); + Range range_value (void); + + int rows (void); + int columns (void); + + tree_constant all (void); + tree_constant any (void); + tree_constant isstr (void); + + tree_constant convert_to_str (void); + + tree_constant cumprod (void); + tree_constant cumsum (void); + tree_constant prod (void); + tree_constant sum (void); + tree_constant sumsq (void); + + tree_constant diag (void); + tree_constant diag (tree_constant& a); + + friend tree_constant fft (tree_constant& a); + friend tree_constant ifft (tree_constant& a); + + friend tree_constant fill_matrix (tree_constant& a, double d, + char *warn_for); + friend tree_constant fill_matrix (tree_constant& a, tree_constant& b, + double d, char *warn_for); + + friend tree_constant identity_matrix (tree_constant& a); + friend tree_constant identity_matrix (tree_constant& a, tree_constant& b); + + friend tree_constant inverse (tree_constant& a); + friend tree_constant determinant (tree_constant& a); + + friend tree_constant find_nonzero_elem_idx (tree_constant& a); + + friend tree_constant *lu (tree_constant& a, int nargout); + friend tree_constant *qr (tree_constant& a, int nargout); + + friend tree_constant *matrix_exp (tree_constant& a); + friend tree_constant *matrix_log (tree_constant& a); + friend tree_constant *matrix_sqrt (tree_constant& a); + + friend tree_constant *collocation_weights (tree_constant *args, + int nargin); + + friend tree_constant *column_max (tree_constant *args, int nargin, + int nargout); + + friend tree_constant *column_min (tree_constant *args, int nargin, + int nargout); + + friend tree_constant *hess (tree_constant *args, int nargin, int nargout); + friend tree_constant *eig (tree_constant *args, int nargin, int nargout); + friend tree_constant *schur (tree_constant *args, int nargin, int nargout); + friend tree_constant *svd (tree_constant *args, int nargin, int nargout); + friend tree_constant *lsode (tree_constant *args, int nargin, int nargout); + friend tree_constant *dassl (tree_constant *args, int nargin, int nargout); + +#ifndef NPSOL_MISSING + friend tree_constant *npsol (tree_constant *args, int nargin, int nargout); +#endif + +#ifndef QPSOL_MISSING + friend tree_constant *qpsol (tree_constant *args, int nargin, int nargout); +#endif + +#ifndef FSQP_MISSING + friend tree_constant *fsqp (tree_constant *args, int nargin, int nargout); +#endif + + friend tree_constant *lpsolve (tree_constant *args, int nargin, int nargout); + + friend tree_constant *fsolve (tree_constant *args, int nargin, int nargout); + + friend tree_constant *do_quad (tree_constant *args, int nargin, int nargout); + + friend tree_constant *rand_internal (tree_constant *args, int nargin, + int nargout); + + friend tree_constant *sort (tree_constant *args, int nargin, int nargout); + + friend tree_constant *feval (tree_constant *args, int nargin, int nargout); + + friend tree_constant eval_string (tree_constant& arg, int& parse_status); + + friend tree_constant get_user_input (tree_constant *args, int nargin, + int nargout, int debug = 0); + + void print_if_string (ostream& os, int warn); + + constant_type const_type (void) { return type_tag; } + + tree_constant mapper (Mapper_fcn& m_fcn, int print); + +private: + int count; + constant_type type_tag; + union + { + double scalar; // A real scalar constant. + Matrix *matrix; // A real matrix constant. + Complex *complex_scalar; // A real scalar constant. + ComplexMatrix *complex_matrix; // A real matrix constant. + char *string; // A character string constant. + Range *range; // A set of evenly spaced values. + }; +}; + +/* + * Constants. Nice -- No need to interpret them anymore. Logically, + * this should be ahead of the tree_constant_rep class, but that + * causes problems with my version of g++ (~2.2.2)... + */ +class tree_constant : public tree +{ +friend class tree_constant_rep; + +public: + tree_constant (void) + { rep = new tree_constant_rep (); rep->count = 1; } + + tree_constant (double d) + { rep = new tree_constant_rep (d); rep->count = 1; } + tree_constant (Matrix& m) + { rep = new tree_constant_rep (m); rep->count = 1; } + tree_constant (DiagMatrix& d) + { rep = new tree_constant_rep (d); rep->count = 1; } + tree_constant (RowVector& v) + { rep = new tree_constant_rep (v); rep->count = 1; } + tree_constant (RowVector& v, int pcv) + { rep = new tree_constant_rep (v, pcv); rep->count = 1; } + tree_constant (ColumnVector& v) + { rep = new tree_constant_rep (v); rep->count = 1; } + tree_constant (ColumnVector& v, int pcv) + { rep = new tree_constant_rep (v, pcv); rep->count = 1; } + + tree_constant (Complex c) + { rep = new tree_constant_rep (c); rep->count = 1; } + tree_constant (ComplexMatrix& m) + { rep = new tree_constant_rep (m); rep->count = 1; } + tree_constant (ComplexDiagMatrix& d) + { rep = new tree_constant_rep (d); rep->count = 1; } + tree_constant (ComplexRowVector& v) + { rep = new tree_constant_rep (v); rep->count = 1; } + tree_constant (ComplexRowVector& v, int pcv) + { rep = new tree_constant_rep (v, pcv); rep->count = 1; } + tree_constant (ComplexColumnVector& v) + { rep = new tree_constant_rep (v); rep->count = 1; } + tree_constant (ComplexColumnVector& v, int pcv) + { rep = new tree_constant_rep (v, pcv); rep->count = 1; } + + tree_constant (const char *s) + { rep = new tree_constant_rep (s); rep->count = 1; } + tree_constant (String& s) + { rep = new tree_constant_rep (s); rep->count = 1; } + + tree_constant (double base, double limit, double inc) + { rep = new tree_constant_rep (base, limit, inc); rep->count = 1; } + tree_constant (Range& r) + { rep = new tree_constant_rep (r); rep->count = 1; } + + tree_constant (tree_constant_rep::constant_type t) + { rep = new tree_constant_rep (t); rep->count = 1; } + + tree_constant (tree_constant& a) + { rep = a.rep; rep->count++; } + tree_constant (tree_constant_rep& r) + { rep = &r; rep->count++; } + + ~tree_constant (void); + +#if defined (MDEBUG) + void *operator new (size_t size); + void operator delete (void *p, size_t size); +#endif + + tree_constant operator = (tree_constant& a) + { + if (--rep->count <= 0 && rep != a.rep) + delete rep; + + rep = a.rep; + rep->count++; + return *this; + } + + int is_constant (void) { return 1; } + + int is_scalar_type (void) { return rep->is_scalar_type (); } + int is_matrix_type (void) { return rep->is_matrix_type (); } + + int is_real_type (void) { return rep->is_real_type (); } + int is_complex_type (void) { return rep->is_complex_type (); } + + int is_numeric_type (void) { return rep->is_numeric_type (); } + + int is_numeric_or_range_type (void) + { return rep->is_numeric_or_range_type (); } + + int is_string_type (void) { return rep->is_string_type (); } + + int valid_as_scalar_index (void) { return rep->valid_as_scalar_index (); } + + int is_defined (void) { return rep->is_defined (); } + int is_undefined (void) { return rep->is_undefined (); } + + double to_scalar (void) { return rep->to_scalar (); } + ColumnVector to_vector (void) { return rep->to_vector (); } + Matrix to_matrix (void) { return rep->to_matrix (); } + + tree_constant_rep::constant_type force_numeric (int force_str_conv = 0) + { return rep->force_numeric (force_str_conv); } + + tree_constant make_numeric (int force_str_conv = 0) + { + if (is_numeric_type ()) + return *this; + else + return rep->make_numeric (force_str_conv); + } + + tree_constant make_numeric_or_range (void) + { + if (is_numeric_type () + || rep->type_tag == tree_constant_rep::range_constant) + return *this; + else + return rep->make_numeric (); + } + + tree_constant make_numeric_or_magic (void) + { + if (is_numeric_type () + || rep->type_tag == tree_constant_rep::magic_colon) + return *this; + else + return rep->make_numeric (); + } + + tree_constant make_numeric_or_range_or_magic (void) + { + if (is_numeric_type () + || rep->type_tag == tree_constant_rep::magic_colon + || rep->type_tag == tree_constant_rep::range_constant) + return *this; + else + return rep->make_numeric (); + } + + tree_constant assign (tree_constant& rhs, tree_constant *args, int nargs) + { + if (rep->count > 1) + { + --rep->count; + rep = new tree_constant_rep (*rep); + rep->count = 1; + } + rep->assign (rhs, args, nargs); + return *this; + } + + int save (ostream& os, int mark_as_global = 0) + { return rep->save (os, mark_as_global); } + int save_three_d (ostream& os, int parametric = 0) + { return rep->save_three_d (os, parametric); } + + int load (istream& is) { return rep->load (is); } + tree_constant_rep::constant_type load + (istream& is, tree_constant_rep::constant_type t) + { return rep->load (is, t); } + + double double_value (void) { return rep->double_value (); } + Matrix matrix_value (void) { return rep->matrix_value (); } + Complex complex_value (void) { return rep->complex_value (); } + ComplexMatrix complex_matrix_value (void) + { return rep->complex_matrix_value (); } + char *string_value (void) { return rep->string_value (); } + Range range_value (void) { return rep->range_value (); } + + int rows (void) { return rep->rows (); } + int columns (void) { return rep->columns (); } + + tree_constant all (void) { return rep->all (); } + tree_constant any (void) { return rep->any (); } + tree_constant isstr (void) { return rep->isstr (); } + + tree_constant convert_to_str (void) { return rep->convert_to_str (); } + + tree_constant cumprod (void) { return rep->cumprod (); } + tree_constant cumsum (void) { return rep->cumsum (); } + tree_constant prod (void) { return rep->prod (); } + tree_constant sum (void) { return rep->sum (); } + tree_constant sumsq (void) { return rep->sumsq (); } + + tree_constant diag (void) { return rep->diag (); } + tree_constant diag (tree_constant& a) { return rep->diag (a); } + + void print_if_string (ostream& os, int warn) + { rep->print_if_string (os, warn); } + + tree_constant_rep::constant_type const_type (void) + { return rep->const_type (); } + + tree_constant mapper (Mapper_fcn& m_fcn, int print) + { return rep->mapper (m_fcn, print); } + + void bump_value (tree::expression_type et) + { + if (rep->count > 1) + { + --rep->count; + rep = new tree_constant_rep (*rep); + rep->count = 1; + } + rep->bump_value (et); + } + + tree_constant eval (int print) + { rep->eval (print); return *this; } + +// A tree constant can have one and only one value to return. + tree_constant *eval (int print, int nargout) + { + rep->eval (print); + tree_constant *retval = new tree_constant [2]; + retval[0] = *this; + return retval; + } + + tree_constant *eval (tree_constant *args, int n_in, int n_out, int print) + { return rep->eval (args, n_in, n_out, print); } + +private: + tree_constant_rep *rep; +}; + +#endif + +/* +;;; Local Variables: *** +;;; mode: C++ *** +;;; page-delimiter: "^/\\*" *** +;;; End: *** +*/
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/pt-plot.cc Sun Aug 08 01:13:40 1993 +0000 @@ -0,0 +1,588 @@ +// tree-plot.cc -*- C++ -*- +/* + +Copyright (C) 1992, 1993 John W. Eaton + +This file is part of Octave. + +Octave is free software; you can redistribute it and/or modify it +under the terms of the GNU General Public License as published by the +Free Software Foundation; either version 2, or (at your option) any +later version. + +Octave is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +for more details. + +You should have received a copy of the GNU General Public License +along with Octave; see the file COPYING. If not, write to the Free +Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. + +*/ + +#ifdef __GNUG__ +#pragma implementation +#endif + +#include <iostream.h> +#include <strstream.h> + +#include "error.h" +#include "utils.h" +#include "tree.h" + +// The number of lines we\'ve plotted so far. +static int plot_line_count; + +// Is this a parametric plot? Makes a difference for 3D plotting. +int parametric_plot = 0; + +/* + * Plotting, eh? + */ + +tree_plot_command::tree_plot_command (void) +{ + range = (tree_plot_limits *) NULL; + plot_list = (tree_subplot_list *) NULL; + ndim = 0; +} + +tree_plot_command::tree_plot_command (tree_subplot_list *plt, int nd) +{ + range = (tree_plot_limits *) NULL; + plot_list = plt; + ndim = nd; +} + +tree_plot_command::tree_plot_command (tree_subplot_list *plt, + tree_plot_limits *rng, int nd) +{ + range = rng; + plot_list = plt; + ndim = nd; +} + +tree_plot_command::~tree_plot_command (void) +{ + delete range; + delete plot_list; +} + +tree_constant +tree_plot_command::eval (int print) +{ + tree_constant retval; + + ostrstream plot_buf; + + switch (ndim) + { + case 2: + plot_buf << "plot"; + break; + case 3: + plot_buf << "splot"; + break; + default: + panic_impossible (); + break; + } + + if (range != (tree_plot_limits *) NULL) + range->print (ndim, plot_buf); + + plot_line_count = 0; + tree_subplot_list *ptr = plot_list; + for ( ; ptr != NULL_TREE ; ptr = ptr->next_elem ()) + { + plot_line_count++; + + if (ptr != plot_list) + plot_buf << ",\\\n "; + + int status = ptr->print (ndim, plot_buf); + if (status < 0) + return retval; + } + +// We need to make sure the buffer is null-terminated because it seems +// that the libg++-2.3 ostrstream::str() function doesn\'t guarantee +// that it will be... + + plot_buf << "\n" << ends; + +// Just testing... +// char *message = plot_buf.str (); +// cout << "[*]" << message << "[*]\n"; + + if (parametric_plot && ndim == 2) + { + warning ("can't make 2D parametric plot -- setting noparametric..."); + send_to_plot_stream ("set noparametric\n"); + char *message = plot_buf.str (); + send_to_plot_stream (message); + delete [] message; + send_to_plot_stream ("set parametric\n"); + } + else + { + char *message = plot_buf.str (); + send_to_plot_stream (message); + delete [] message; + } + + return retval; +} + +tree_subplot_list::tree_subplot_list (void) +{ + plot_data = NULL_TREE; + using = (tree_subplot_using *) NULL; + title = NULL_TREE; + style = (tree_subplot_style *) NULL; + next = (tree_subplot_list *) NULL; +} + +tree_subplot_list::tree_subplot_list (tree *data) +{ + plot_data = data; + using = (tree_subplot_using *) NULL; + title = NULL_TREE; + style = (tree_subplot_style *) NULL; + next = (tree_subplot_list *) NULL; +} + +tree_subplot_list::tree_subplot_list (tree_subplot_list *t) +{ + plot_data = t->plot_data; + using = t->using; + title = t->title; + style = t->style; + next = t->next; +} + +tree_subplot_list::tree_subplot_list (tree_subplot_using *u, tree *t, + tree_subplot_style *s) +{ + plot_data = NULL_TREE; + using = u; + title = t; + style = s; + next = (tree_subplot_list *) NULL; +} + +tree_subplot_list::~tree_subplot_list (void) +{ + delete plot_data; + delete using; + delete title; + delete style; + delete next; +} + +tree_subplot_list * +tree_subplot_list::set_data (tree *data) +{ + plot_data = data; + return this; +} + +tree_subplot_list * +tree_subplot_list::chain (tree_subplot_list *t) +{ + tree_subplot_list *tmp = new tree_subplot_list (t); + tmp->next = this; + return tmp; +} + +tree_subplot_list * +tree_subplot_list::reverse (void) +{ + tree_subplot_list *list = this; + tree_subplot_list *next; + tree_subplot_list *prev = (tree_subplot_list *) NULL; + + while (list != (tree_subplot_list *) NULL) + { + next = list->next; + list->next = prev; + prev = list; + list = next; + } + return prev; +} + +tree_subplot_list * +tree_subplot_list::next_elem (void) +{ + return next; +} + +tree_constant +tree_subplot_list::eval (int print) +{ + return plot_data->eval (0); +} + +int +tree_subplot_list::print (int ndim, ostrstream& plot_buf) +{ + int nc = 0; + if (plot_data != NULL_TREE) + { + tree_constant data = plot_data->eval (0); + if (data.is_defined ()) + { + nc = data.columns (); + char *file = (char *) NULL; + switch (ndim) + { + case 2: + file = save_in_tmp_file (data, ndim); + break; + case 3: + file = save_in_tmp_file (data, ndim, parametric_plot); + break; + default: + panic_impossible (); + break; + } + + if (file) + { + mark_for_deletion (file); + plot_buf << " \"" << file << '"'; + } + } + else + return -1; + } + else + return -1; + + if (using != (tree_subplot_using *) NULL) + { + int status = using->print (ndim, nc, plot_buf); + if (status < 0) + return -1; + } + + if (title != NULL_TREE) + { + tree_constant tmp = title->eval (0); + if (tmp.is_string_type ()) + plot_buf << " title " << '"' << tmp.string_value () << '"'; + else + { + warning ("line title must be a string"); + plot_buf << " title " << '"' << "line " << plot_line_count << '"'; + } + } + else + plot_buf << " title " << '"' << "line " << plot_line_count << '"'; + + if (style != (tree_subplot_style *) NULL) + { + int status = style->print (plot_buf); + if (status < 0) + return -1; + } + + return 0; +} + +tree_plot_limits::tree_plot_limits (void) +{ + x_range = (tree_plot_range *) NULL; + y_range = (tree_plot_range *) NULL; + z_range = (tree_plot_range *) NULL; +} + +tree_plot_limits::tree_plot_limits (tree_plot_range *xlim) +{ + x_range = xlim; + y_range = (tree_plot_range *) NULL; + z_range = (tree_plot_range *) NULL; +} + +tree_plot_limits::tree_plot_limits (tree_plot_range *xlim, + tree_plot_range *ylim) +{ + x_range = xlim; + y_range = ylim; + z_range = (tree_plot_range *) NULL; +} + +tree_plot_limits::tree_plot_limits (tree_plot_range *xlim, + tree_plot_range *ylim, + tree_plot_range *zlim) +{ + x_range = xlim; + y_range = ylim; + z_range = zlim; +} + +tree_plot_limits::~tree_plot_limits (void) +{ + delete x_range; + delete y_range; + delete z_range; +} + +tree_constant +tree_plot_limits::eval (int print) +{ + tree_constant retval; + return retval; +} + +void +tree_plot_limits::print (int ndim, ostrstream& plot_buf) +{ + if (ndim == 2 || ndim == 3) + { + if (x_range != (tree_plot_range *) NULL) + x_range->print (plot_buf); + else + return; + + if (y_range != (tree_plot_range *) NULL) + y_range->print (plot_buf); + else + return; + } + + if (ndim == 3 && z_range != (tree_plot_range *) NULL) + z_range->print (plot_buf); +} + +tree_plot_range::tree_plot_range (void) +{ + lower = NULL_TREE; + upper = NULL_TREE; +} + +tree_plot_range::tree_plot_range (tree *l, tree *u) +{ + lower = l; + upper = u; +} + +tree_plot_range::~tree_plot_range (void) +{ + delete lower; + delete upper; +} + +tree_constant +tree_plot_range::eval (int print) +{ + tree_constant retval; + return retval; +} + +void +tree_plot_range::print (ostrstream& plot_buf) +{ + plot_buf << " ["; + + if (lower != NULL_TREE) + { + tree_constant lower_val = lower->eval (0); + double lo = lower_val.to_scalar (); + plot_buf << lo; + } + + plot_buf << ":"; + + if (upper != NULL_TREE) + { + tree_constant upper_val = upper->eval (0); + double hi = upper_val.to_scalar (); + plot_buf << hi; + } + + plot_buf << "]"; +} + +tree_subplot_using::tree_subplot_using (void) +{ + qualifier_count = 0; + x[0] = NULL_TREE; + x[1] = NULL_TREE; + x[2] = NULL_TREE; + x[3] = NULL_TREE; + scanf_fmt = NULL_TREE; +} + +tree_subplot_using::tree_subplot_using (tree *fmt) +{ + qualifier_count = 0; + x[0] = NULL_TREE; + x[1] = NULL_TREE; + x[2] = NULL_TREE; + x[3] = NULL_TREE; + scanf_fmt = fmt; +} + +tree_subplot_using::~tree_subplot_using (void) +{ + delete scanf_fmt; +} + +tree_subplot_using * +tree_subplot_using::set_format (tree *fmt) +{ + scanf_fmt = fmt; + return this; +} + +tree_subplot_using * +tree_subplot_using::add_qualifier (tree *t) +{ + if (qualifier_count < 4) + x[qualifier_count] = t; + + qualifier_count++; + + return this; +} + +tree_constant +tree_subplot_using::eval (int print) +{ + tree_constant retval; + return retval; +} + +int +tree_subplot_using::print (int ndim, int n_max, ostrstream& plot_buf) +{ + if ((ndim == 2 && qualifier_count > 4) + || (ndim == 3 && qualifier_count > 3)) + return -1; + + for (int i = 0; i < qualifier_count; i++) + { + if (x[i] != NULL_TREE) + { + tree_constant tmp = x[i]->eval (0); + double val; + if (tmp.is_defined ()) + { + val = tmp.to_scalar (); + if (i == 0) + plot_buf << " using "; + else + plot_buf << ":"; + + int n = NINT (val); + + if (n > n_max || n < 1) + { + error ("using: column %d out of range", n); + return -1; + } + else + plot_buf << n; + } + else + return -1; + } + else + return -1; + } + + if (scanf_fmt != NULL_TREE) + warning ("ignoring scanf format in plot command"); + + return 0; +} + +tree_subplot_style::tree_subplot_style (void) +{ + style = (char *) NULL; + linetype = NULL_TREE; + pointtype = NULL_TREE; +} + +tree_subplot_style::tree_subplot_style (char *s) +{ + style = strsave (s); + linetype = NULL_TREE; + pointtype = NULL_TREE; +} + +tree_subplot_style::tree_subplot_style (char *s, tree *lt) +{ + style = strsave (s); + linetype = lt; + pointtype = NULL_TREE; +} + +tree_subplot_style::tree_subplot_style (char *s, tree *lt, tree *pt) +{ + style = strsave (s); + linetype = lt; + pointtype = pt; +} + +tree_subplot_style::~tree_subplot_style (void) +{ + delete [] style; + delete linetype; + delete pointtype; +} + +tree_constant +tree_subplot_style::eval (int print) +{ + tree_constant retval; + return retval; +} + +int +tree_subplot_style::print (ostrstream& plot_buf) +{ + if (style != (char *) NULL) + { + plot_buf << " with " << style; + + if (linetype != NULL_TREE) + { + tree_constant tmp = linetype->eval (0); + if (tmp.is_defined ()) + { + double val = tmp.to_scalar (); + plot_buf << " " << NINT (val); + } + else + return -1; + } + + if (pointtype != NULL_TREE) + { + tree_constant tmp = pointtype->eval (0); + if (tmp.is_defined ()) + { + double val = tmp.to_scalar (); + plot_buf << " " << NINT (val); + } + else + return -1; + } + } + else + return -1; + + return 0; +} + +/* +;;; Local Variables: *** +;;; mode: C++ *** +;;; page-delimiter: "^/\\*" *** +;;; End: *** +*/
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/qpsol.cc Sun Aug 08 01:13:40 1993 +0000 @@ -0,0 +1,189 @@ +// tc-qpsol.cc -*- C++ -*- +/* + +Copyright (C) 1993 John W. Eaton + +This file is part of Octave. + +Octave is free software; you can redistribute it and/or modify it +under the terms of the GNU General Public License as published by the +Free Software Foundation; either version 2, or (at your option) any +later version. + +Octave is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +for more details. + +You should have received a copy of the GNU General Public License +along with Octave; see the file COPYING. If not, write to the Free +Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. + +*/ + +#ifdef __GNUG__ +#pragma implementation +#endif + +#ifndef QPSOL_MISSING + +#include "QPSOL.h" + +#include "tree-const.h" +#include "variables.h" +#include "gripes.h" +#include "error.h" +#include "utils.h" + +// This should probably be defined in some shared file and declared in +// a header file... +extern int linear_constraints_ok (const ColumnVector& x, + const ColumnVector& llb, const Matrix& c, + const ColumnVector& lub, char *warn_for, + int warn); + +#ifdef WITH_DLD +tree_constant * +builtin_qpsol_2 (tree_constant *args, int nargin, int nargout) +{ + return qpsol (args, nargin, nargout); +} +#endif + +tree_constant * +qpsol (tree_constant *args, int nargin, int nargout) +{ +/* + +Handle all of the following: + + 1. qpsol (x, H, c) + 2. qpsol (x, H, c, lb, ub) + 3. qpsol (x, H, c, lb, ub, llb, A, lub) + 4. qpsol (x, H, c, llb, A, lub) + +*/ + +// Assumes that we have been given the correct number of arguments. + + tree_constant *retval = NULL_TREE_CONST; + + ColumnVector x = args[1].to_vector (); + if (x.capacity () == 0) + { + message ("qpsol", "expecting vector as first argument"); + return retval; + } + + Matrix H = args[2].to_matrix (); + if (H.rows () != H.columns () || H.rows () != x.capacity ()) + { + message ("qpsol", "H must be a square matrix consistent with the\ + size of x"); + return retval; + } + + ColumnVector c = args[3].to_vector (); + if (c.capacity () != x.capacity ()) + { + message ("qpsol", "c must be a vector the same size as x"); + return retval; + } + + Bounds bounds; + if (nargin == 6 || nargin == 9) + { + ColumnVector lb = args[4].to_vector (); + ColumnVector ub = args[5].to_vector (); + + int lb_len = lb.capacity (); + int ub_len = ub.capacity (); + if (lb_len != ub_len || lb_len != x.capacity ()) + { + message ("qpsol", "lower and upper bounds and decision variable\n\ + vector must all have the same number of elements"); + return retval; + } + + bounds.resize (lb_len); + bounds.set_lower_bounds (lb); + bounds.set_upper_bounds (ub); + } + + ColumnVector soln; + double objf; + ColumnVector lambda; + int inform; + + if (nargin == 4) + { + // 1. qpsol (x, H, c) + + QPSOL qp (x, H, c); + soln = qp.minimize (objf, inform, lambda); + + goto solved; + } + + if (nargin == 6) + { + // 2. qpsol (x, H, c, lb, ub) + + QPSOL qp (x, H, c, bounds); + soln = qp.minimize (objf, inform, lambda); + + goto solved; + } + + if (nargin == 7 || nargin == 9) + { + ColumnVector lub = args[nargin-1].to_vector (); + Matrix A = args[nargin-2].to_matrix (); + ColumnVector llb = args[nargin-3].to_vector (); + + LinConst linear_constraints (llb, A, lub); + + if (! linear_constraints_ok (x, llb, A, lub, "qpsol", 1)) + return retval; + + if (nargin == 9) + { + // 3. qpsol (x, H, c, lb, ub, llb, A, lub) + + QPSOL qp (x, H, c, bounds, linear_constraints); + soln = qp.minimize (objf, inform, lambda); + } + else + { + // 4. qpsol (x, H, c, llb, A, lub) + + QPSOL qp (x, H, c, linear_constraints); + soln = qp.minimize (objf, inform, lambda); + } + goto solved; + } + + return retval; + + solved: + + retval = new tree_constant [nargout+1]; + retval[0] = tree_constant (soln, 1); + if (nargout > 1) + retval[1] = tree_constant (objf); + if (nargout > 2) + retval[2] = tree_constant ((double) inform); + if (nargout > 3) + retval[3] = tree_constant (lambda); + + return retval; +} + +#endif + +/* +;;; Local Variables: *** +;;; mode: C++ *** +;;; page-delimiter: "^/\\*" *** +;;; End: *** +*/
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/qr.cc Sun Aug 08 01:13:40 1993 +0000 @@ -0,0 +1,113 @@ +// tc-qr.cc -*- C++ -*- +/* + +Copyright (C) 1993 John W. Eaton + +This file is part of Octave. + +Octave is free software; you can redistribute it and/or modify it +under the terms of the GNU General Public License as published by the +Free Software Foundation; either version 2, or (at your option) any +later version. + +Octave is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +for more details. + +You should have received a copy of the GNU General Public License +along with Octave; see the file COPYING. If not, write to the Free +Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. + +*/ + +#ifdef __GNUG__ +#pragma implementation +#endif + +#include "Matrix.h" + +#include "tree-const.h" +#include "user-prefs.h" +#include "gripes.h" + +#ifdef WITH_DLD +tree_constant * +builtin_qr_2 (tree_constant *args, int nargin, int nargout) +{ + return qr (args[1], nargout); +} +#endif + +tree_constant * +qr (tree_constant& a, int nargout) +{ + tree_constant *retval = new tree_constant [3]; + + tree_constant tmp = a.make_numeric ();; + + int nr = tmp.rows (); + int nc = tmp.columns (); + + if (nr == 0 || nc == 0) + { + int flag = user_pref.propagate_empty_matrices; + if (flag != 0) + { + if (flag < 0) + gripe_empty_arg ("qr", 0); + Matrix m; + retval = new tree_constant [3]; + retval[0] = tree_constant (m); + retval[1] = tree_constant (m); + } + else + gripe_empty_arg ("qr", 1); + + return retval; + } + + switch (tmp.const_type ()) + { + case tree_constant_rep::matrix_constant: + { + Matrix m = tmp.matrix_value (); + QR fact (m); + retval[0] = tree_constant (fact.Q ()); + retval[1] = tree_constant (fact.R ()); + } + break; + case tree_constant_rep::complex_matrix_constant: + { + ComplexMatrix m = tmp.complex_matrix_value (); + ComplexQR fact (m); + retval[0] = tree_constant (fact.Q ()); + retval[1] = tree_constant (fact.R ()); + } + break; + case tree_constant_rep::scalar_constant: + { + double d = tmp.double_value (); + retval[0] = tree_constant (1.0); + retval[1] = tree_constant (d); + } + break; + case tree_constant_rep::complex_scalar_constant: + { + Complex c = tmp.complex_value (); + retval[0] = tree_constant (1.0); + retval[1] = tree_constant (c); + } + break; + default: + break; + } + return retval; +} + +/* +;;; Local Variables: *** +;;; mode: C++ *** +;;; page-delimiter: "^/\\*" *** +;;; End: *** +*/
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/quad.cc Sun Aug 08 01:13:40 1993 +0000 @@ -0,0 +1,187 @@ +// tc-quad.cc -*- C++ -*- +/* + +Copyright (C) 1993 John W. Eaton + +This file is part of Octave. + +Octave is free software; you can redistribute it and/or modify it +under the terms of the GNU General Public License as published by the +Free Software Foundation; either version 2, or (at your option) any +later version. + +Octave is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +for more details. + +You should have received a copy of the GNU General Public License +along with Octave; see the file COPYING. If not, write to the Free +Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. + +*/ + +#ifdef __GNUG__ +#pragma implementation +#endif + +#include "Quad.h" + +#include "tree-const.h" +#include "variables.h" +#include "mappers.h" +#include "gripes.h" +#include "error.h" +#include "utils.h" + +// Global pointer for user defined function required by quadrature functions. +static tree *quad_fcn; + +#ifdef WITH_DLD +tree_constant * +builtin_quad_2 (tree_constant *args, int nargin, int nargout) +{ + return do_quad (args, nargin, nargout); +} +#endif + +double +quad_user_function (double x) +{ + double retval = 0.0; + +// tree_constant name = tree_constant (quad_fcn->name ()); + tree_constant *args = new tree_constant [2]; +// args[0] = name; + args[1] = tree_constant (x); + + if (quad_fcn != NULL_TREE) + { + tree_constant *tmp = quad_fcn->eval (args, 2, 1, 0); + delete [] args; + if (tmp != NULL_TREE_CONST && tmp[0].is_defined ()) + { + retval = tmp[0].to_scalar (); + delete [] tmp; + } + else + { + delete [] tmp; + gripe_user_supplied_eval ("quad"); + jump_to_top_level (); + } + } + + return retval; +} + +tree_constant * +do_quad (tree_constant *args, int nargin, int nargout) +{ +// Assumes that we have been given the correct number of arguments. + + tree_constant *retval = NULL_TREE_CONST; + + quad_fcn = is_valid_function (args[1], "fsolve", 1); + if (quad_fcn == NULL_TREE + || takes_correct_nargs (quad_fcn, 2, "fsolve", 1) != 1) + return retval; + + double a = args[2].to_scalar (); + double b = args[3].to_scalar (); + + int indefinite = 0; + IndefQuad::IntegralType indef_type = IndefQuad::doubly_infinite; + double bound = 0.0; + if ((int) xisinf (a) && (int) xisinf (b)) + { + indefinite = 1; + indef_type = IndefQuad::doubly_infinite; + } + else if ((int) xisinf (a)) + { + indefinite = 1; + bound = b; + indef_type = IndefQuad::neg_inf_to_bound; + } + else if ((int) xisinf (b)) + { + indefinite = 1; + bound = a; + indef_type = IndefQuad::bound_to_inf; + } + + int ier = 0; + int nfun = 0; + double abserr = 0.0; + double val = 0.0; + double abstol = 1e-6; + double reltol = 1e-6; + Vector tol (2); + Vector sing; + int have_sing = 0; + switch (nargin) + { + case 6: + if (indefinite) + { + message ("quad", "sorry, singularities not allowed on infinite intervals"); + return retval; + } + have_sing = 1; + sing = args[5].to_vector (); + case 5: + tol = args[4].to_vector (); + switch (tol.capacity ()) + { + case 2: + reltol = tol.elem (1); + case 1: + abstol = tol.elem (0); + break; + default: + message ("quad", "expecting tol to contain no more than two values"); + return retval; + } + case 4: + if (indefinite) + { + IndefQuad iq (quad_user_function, bound, indef_type, abstol, reltol); + val = iq.integrate (ier, nfun, abserr); + } + else + { + if (have_sing) + { + DefQuad dq (quad_user_function, a, b, sing, abstol, reltol); + val = dq.integrate (ier, nfun, abserr); + } + else + { + DefQuad dq (quad_user_function, a, b, abstol, reltol); + val = dq.integrate (ier, nfun, abserr); + } + } + break; + default: + panic_impossible (); + break; + } + + retval = new tree_constant [5]; + + retval[0] = tree_constant (val); + retval[1] = tree_constant ((double) ier); + retval[2] = tree_constant ((double) nfun); + retval[3] = tree_constant (abserr); + + return retval; +} + +/* +;;; Local Variables: *** +;;; mode: C++ *** +;;; page-delimiter: "^/\\*" *** +;;; End: *** +*/ +
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/rand.cc Sun Aug 08 01:13:40 1993 +0000 @@ -0,0 +1,260 @@ +// tc-rand.cc -*- C++ -*- +/* + +Copyright (C) 1993 John W. Eaton + +This file is part of Octave. + +Octave is free software; you can redistribute it and/or modify it +under the terms of the GNU General Public License as published by the +Free Software Foundation; either version 2, or (at your option) any +later version. + +Octave is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +for more details. + +You should have received a copy of the GNU General Public License +along with Octave; see the file COPYING. If not, write to the Free +Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. + +*/ + +#ifdef __GNUG__ +#pragma implementation +#endif + +#include "tree-const.h" +#include "f77-uscore.h" +#include "error.h" +#include "utils.h" + +// Possible distributions of random numbers. +enum rand_dist { uniform, normal }; + +// Current distribution of random numbers. +static rand_dist current_distribution = uniform; + +extern "C" +{ + int *F77_FCN (dgennor) (double*, double*, double*); + int *F77_FCN (dgenunf) (double*, double*, double*); + int *F77_FCN (setall) (int*, int*); + int *F77_FCN (getsd) (int*, int*); +} + +#ifdef WITH_DLD +tree_constant * +builtin_rand_2 (tree_constant *args, int nargin, int nargout) +{ + return rand_internal (args, nargin, nargout); +} +#endif + +static double +curr_rand_seed (void) +{ + union d2i { double d; int i[2]; }; + union d2i u; + F77_FCN (getsd) (&(u.i[0]), &(u.i[1])); + return u.d; +} + +static int +force_to_fit_range (int i, int lo, int hi) +{ + assert (hi > lo && lo >= 0 && hi > lo); + + i = i > 0 ? i : -i; + + if (i < lo) + i = lo; + else if (i > hi) + i = i % hi; + + return i; +} + +static void +set_rand_seed (double val) +{ + union d2i { double d; int i[2]; }; + union d2i u; + u.d = val; + int i0 = force_to_fit_range (u.i[0], 1, 2147483563); + int i1 = force_to_fit_range (u.i[1], 1, 2147483399); + F77_FCN (setall) (&i0, &i1); +} + +static char * +curr_rand_dist (void) +{ + if (current_distribution == uniform) + return "uniform"; + else if (current_distribution == normal) + return "normal"; + else + { + panic_impossible (); + return (char *) NULL; + } +} + +tree_constant * +rand_internal (tree_constant *args, int nargin, int nargout) +{ +// Assumes that we have been given the correct number of arguments. + + tree_constant *retval = NULL_TREE_CONST; + + static int initialized = 0; + if (! initialized) + { +// Make the random number generator give us a different sequence every +// time we start octave unless we specifically set the seed. +#if 0 + int s0 = 1234567890; + int s1 = 123456789; +#else + time_t now; + struct tm *tm; + + time (&now); + tm = localtime (&now); + + int s0 = tm->tm_min * 60 + tm->tm_sec; + int s1 = (tm->tm_mday - 1) * 24 * 3600 + tm->tm_hour * 3600 + s0; +#endif + s0 = force_to_fit_range (s0, 1, 2147483563); + s1 = force_to_fit_range (s1, 1, 2147483399); + + F77_FCN (setall) (&s0, &s1); + initialized = 1; + } + + int n = 0; + int m = 0; + if (nargin == 1) + { + n = 1; + m = 1; + goto gen_matrix; + } + else if (nargin == 2) + { + switch (args[1].const_type ()) + { + case tree_constant_rep::string_constant: + char *s_arg = args[1].string_value (); + if (strcmp (s_arg, "dist") == 0) + { + retval = new tree_constant [2]; + char *s = curr_rand_dist (); + retval[0] = tree_constant (s); + } + else if (strcmp (s_arg, "seed") == 0) + { + retval = new tree_constant [2]; + double d = curr_rand_seed (); + retval[0] = tree_constant (d); + } + else if (strcmp (s_arg, "uniform") == 0) + current_distribution = uniform; + else if (strcmp (s_arg, "normal") == 0) + current_distribution = normal; + else + { + delete [] retval; + retval = NULL_TREE_CONST; + message ("rand", "unrecognized string argument"); + } + break; + case tree_constant_rep::scalar_constant: + case tree_constant_rep::complex_scalar_constant: + n = NINT (args[1].double_value ()); + m = n; + goto gen_matrix; + case tree_constant_rep::range_constant: + { + Range r = args[1].range_value (); + n = 1; + m = NINT (r.nelem ()); + } + goto gen_matrix; + case tree_constant_rep::matrix_constant: + case tree_constant_rep::complex_matrix_constant: + n = NINT (args[1].rows ()); + m = NINT (args[1].columns ()); + goto gen_matrix; + default: + panic_impossible (); + break; + } + } + else if (nargin == 3) + { + if (args[1].is_string_type () + && strcmp (args[1].string_value (), "seed") == 0) + { + double d = args[2].to_scalar (); + set_rand_seed (d); + } + else + { + n = NINT (args[1].to_scalar ()); + m = NINT (args[2].to_scalar ()); + goto gen_matrix; + } + } + + return retval; + + gen_matrix: + + if (n == 0 || m == 0) + { + retval = new tree_constant [2]; + Matrix m (0, 0); + retval[0] = tree_constant (m); + } + else if (n > 0 && m > 0) + { + retval = new tree_constant [2]; + Matrix rand_mat (n, m); + for (int j = 0; j < m; j++) + for (int i = 0; i < n; i++) + { + double d_zero = 0.0; + double d_one = 1.0; + double val; + switch (current_distribution) + { + case uniform: + F77_FCN (dgenunf) (&d_zero, &d_one, &val); + rand_mat.elem (i, j) = val; + break; + case normal: + F77_FCN (dgennor) (&d_zero, &d_one, &val); + rand_mat.elem (i, j) = val; + break; + default: + panic_impossible (); + break; + } + } + + retval[0] = tree_constant (rand_mat); + } + else + message ("rand", "invalid negative argument"); + + return retval; +} + +/* +;;; Local Variables: *** +;;; mode: C++ *** +;;; page-delimiter: "^/\\*" *** +;;; End: *** +*/
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/schur.cc Sun Aug 08 01:13:40 1993 +0000 @@ -0,0 +1,180 @@ +// tc-schur.cc -*- C++ -*- +/* + +Copyright (C) 1993 John W. Eaton + +This file is part of Octave. + +Octave is free software; you can redistribute it and/or modify it +under the terms of the GNU General Public License as published by the +Free Software Foundation; either version 2, or (at your option) any +later version. + +Octave is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +for more details. + +You should have received a copy of the GNU General Public License +along with Octave; see the file COPYING. If not, write to the Free +Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. + +*/ + +#ifdef __GNUG__ +#pragma implementation +#endif + +#include "Matrix.h" + +#include "tree-const.h" +#include "user-prefs.h" +#include "error.h" +#include "gripes.h" + +#ifdef WITH_DLD +tree_constant * +builtin_schur_2 (tree_constant *args, int nargin, int nargout) +{ + return schur (args, nargin, nargout); +} +#endif + +tree_constant * +schur (tree_constant *args, int nargin, int nargout) +{ + tree_constant *retval = NULL_TREE_CONST; + + tree_constant arg = args[1].make_numeric (); + + char *ord; + if (nargin != 3) + ord = "U"; + else + ord = args[2].string_value (); + + if (*ord != 'U' && *ord != 'A' && *ord != 'D' + && *ord != 'u' && *ord != 'a' && *ord != 'd') + { + warning ("schur: incorrect ordered schur argument `%c'", *ord); + Matrix m; + retval = new tree_constant [3]; + retval[0] = tree_constant (m); + retval[1] = tree_constant (m); + return retval; + } + int a_nr = arg.rows (); + int a_nc = arg.columns (); + + if (a_nr == 0 || a_nc == 0) + { + int flag = user_pref.propagate_empty_matrices; + if (flag != 0) + { + if (flag < 0) + warning ("schur: argument is empty matrix"); + Matrix m; + retval = new tree_constant [3]; + retval[0] = tree_constant (m); + retval[1] = tree_constant (m); + } + else + error ("schur: empty matrix is invalid as argument"); + + return retval; + } + if (a_nr != a_nc) + { + gripe_square_matrix_required ("schur"); + return retval; + } + + Matrix tmp; + ComplexMatrix ctmp; + + switch (arg.const_type ()) + { + case tree_constant_rep::matrix_constant: + { + tmp = arg.matrix_value (); + + SCHUR result (tmp,ord); + + if (nargout == 1) + { + retval = new tree_constant [2]; + retval[0] = tree_constant (result.schur_matrix ()); + } + else + { + retval = new tree_constant [3]; + retval[0] = tree_constant (result.unitary_matrix ()); + retval[1] = tree_constant (result.schur_matrix ()); + } + } + break; + case tree_constant_rep::complex_matrix_constant: + { + ctmp = arg.complex_matrix_value (); + + ComplexSCHUR result (ctmp,ord); + + if (nargout == 1) + { + retval = new tree_constant [2]; + retval[0] = tree_constant (result.schur_matrix ()); + } + else + { + retval = new tree_constant [3]; + retval[0] = tree_constant (result.unitary_matrix ()); + retval[1] = tree_constant (result.schur_matrix ()); + } + } + break; + case tree_constant_rep::scalar_constant: + { + double d = arg.double_value (); + if (nargout == 1) + { + retval = new tree_constant [2]; + retval[0] = tree_constant (d); + } + else + { + retval = new tree_constant [3]; + retval[0] = tree_constant (1); + retval[1] = tree_constant (d); + } + } + break; + case tree_constant_rep::complex_scalar_constant: + { + Complex c = arg.complex_value (); + if (nargout == 1) + { + retval = new tree_constant [2]; + retval[0] = tree_constant (c); + } + else + { + retval = new tree_constant [3]; + retval[0] = tree_constant (1); + retval[1] = tree_constant (c); + } + } + break; + default: + panic_impossible (); + break; + } + + return retval; +} + +/* +;;; Local Variables: *** +;;; mode: C++ *** +;;; page-delimiter: "^/\\*" *** +;;; End: *** +*/
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/sighandlers.cc Sun Aug 08 01:13:40 1993 +0000 @@ -0,0 +1,319 @@ +// sighandlers.cc -*- C++ -*- +/* + +Copyright (C) 1992, 1993 John W. Eaton + +This file is part of Octave. + +Octave is free software; you can redistribute it and/or modify it +under the terms of the GNU General Public License as published by the +Free Software Foundation; either version 2, or (at your option) any +later version. + +Octave is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +for more details. + +You should have received a copy of the GNU General Public License +along with Octave; see the file COPYING. If not, write to the Free +Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. + +*/ + +#ifdef __GNUG__ +#pragma implementation +#endif + +#include <signal.h> + +#include "sighandlers.h" +#include "octave.h" +#include "error.h" +#include "utils.h" + +// Nonzero means we have already printed a message for this series of +// SIGPIPES. We assume that the writer will eventually give up. +int pipe_handler_error_count = 0; + +// Nonzero means we can be interrupted. +int can_interrupt = 0; + +static void +my_friendly_exit (const char *sig_name, int sig_number) +{ + error ("caught %s -- stopping myself...", sig_name); + clean_up_and_exit (sig_number); +} + +/* + * Some of these may eventually perform different actions... + */ + +static RETSIGTYPE +sigabrt_handler (int i) +{ + my_friendly_exit ("SIGABRT", i); +} + +static RETSIGTYPE +sigalrm_handler (int i) +{ + my_friendly_exit ("SIGALRM", i); +} + +static RETSIGTYPE +sigbus_handler (int i) +{ + my_friendly_exit ("SIGBUS", i); +} + +static RETSIGTYPE +sigemt_handler (int i) +{ + my_friendly_exit ("SIGEMT", i); +} + +static RETSIGTYPE +sigfpe_handler (int i) +{ + my_friendly_exit ("SIGFPE", i); +} + +static RETSIGTYPE +sighup_handler (int i) +{ + my_friendly_exit ("SIGHUP", i); +} + +static RETSIGTYPE +sigill_handler (int i) +{ + my_friendly_exit ("SIGILL", i); +} + +/* + * Handle SIGINT by restarting the parser (see octave.cc). + */ +static RETSIGTYPE +sigint_handler (int i) +{ + if (can_interrupt) + { + jump_to_top_level (); + panic_impossible (); + } + +#if RETSIGTYPE == void + return; +#else + return 0; +#endif +} + +static RETSIGTYPE +sigiot_handler (int i) +{ + my_friendly_exit ("SIGIOT", i); +} + +static RETSIGTYPE +siglost_handler (int i) +{ + my_friendly_exit ("SIGLOST", i); +} + +static RETSIGTYPE +sigpipe_handler (int i) +{ + if (pipe_handler_error_count++ == 0) + message ((char *) NULL, "broken pipe"); + +// Don\'t loop forever on account of this. + if (pipe_handler_error_count > 100) + jump_to_top_level (); + +#if RETSIGTYPE == void + return; +#else + return 0; +#endif +} + +static RETSIGTYPE +sigpoll_handler (int i) +{ + my_friendly_exit ("SIGPOLL", i); +} + +static RETSIGTYPE +sigprof_handler (int i) +{ + my_friendly_exit ("SIGPROF", i); +} + +static RETSIGTYPE +sigquit_handler (int i) +{ + my_friendly_exit ("SIGQUIT", i); +} + +static RETSIGTYPE +sigsegv_handler (int i) +{ + my_friendly_exit ("SIGSEGV", i); +} + +static RETSIGTYPE +sigsys_handler (int i) +{ + my_friendly_exit ("SIGSYS", i); +} + +static RETSIGTYPE +sigterm_handler (int i) +{ + my_friendly_exit ("SIGTERM", i); +} + +static RETSIGTYPE +sigtrap_handler (int i) +{ + my_friendly_exit ("SIGTRAP", i); +} + +static RETSIGTYPE +sigusr1_handler (int i) +{ + my_friendly_exit ("SIGUSR1", i); +} + +static RETSIGTYPE +sigusr2_handler (int i) +{ + my_friendly_exit ("SIGUSR2", i); +} + +static RETSIGTYPE +sigvtalrm_handler (int i) +{ + my_friendly_exit ("SIGVTALRM", i); +} + +static RETSIGTYPE +sigxcpu_handler (int i) +{ + my_friendly_exit ("SIGXCPU", i); +} + +static RETSIGTYPE +sigxfsz_handler (int i) +{ + my_friendly_exit ("SIGXFSZ", i); +} + +/* + * Install all the handlers for the signals we might care about. + */ +void +install_signal_handlers (void) +{ +#ifdef SIGABRT + signal (SIGABRT, sigabrt_handler); +#endif + +#ifdef SIGALRM + signal (SIGALRM, sigalrm_handler); +#endif + +#ifdef SIGBUS + signal (SIGBUS, sigbus_handler); +#endif + +#ifdef SIGEMT + signal (SIGEMT, sigemt_handler); +#endif + +#ifdef SIGFPE + signal (SIGFPE, sigfpe_handler); +#endif + +#ifdef SIGHUP + signal (SIGHUP, sighup_handler); +#endif + +#ifdef SIGILL + signal (SIGILL, sigill_handler); +#endif + +#ifdef SIGINT + signal (SIGINT, sigint_handler); +#endif + +#ifdef SIGIOT + signal (SIGIOT, sigiot_handler); +#endif + +#ifdef SIGLOST + signal (SIGLOST, siglost_handler); +#endif + +#ifdef SIGPIPE + signal (SIGPIPE, sigpipe_handler); +#endif + +#ifdef SIGPOLL + signal (SIGPOLL, sigpoll_handler); +#endif + +#ifdef SIGPROF + signal (SIGPROF, sigprof_handler); +#endif + +#ifdef SIGQUIT + signal (SIGQUIT, sigquit_handler); +#endif + +#ifdef SIGSEGV + signal (SIGSEGV, sigsegv_handler); +#endif + +#ifdef SIGSYS + signal (SIGSYS, sigsys_handler); +#endif + +#ifdef SIGTERM + signal (SIGTERM, sigterm_handler); +#endif + +#ifdef SIGTRAP + signal (SIGTRAP, sigtrap_handler); +#endif + +#ifdef SIGUSR1 + signal (SIGUSR1, sigusr1_handler); +#endif + +#ifdef SIGUSR2 + signal (SIGUSR2, sigusr2_handler); +#endif + +#ifdef SIGVTALRM + signal (SIGVTALRM, sigvtalrm_handler); +#endif + +#ifdef SIGXCPU + signal (SIGXCPU, sigxcpu_handler); +#endif + +#ifdef SIGXFSZ + signal (SIGXFSZ, sigxfsz_handler); +#endif +} + +/* +;;; Local Variables: *** +;;; mode: C++ *** +;;; page-delimiter: "^/\\*" *** +;;; End: *** +*/
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/sighandlers.h Sun Aug 08 01:13:40 1993 +0000 @@ -0,0 +1,49 @@ +// sighandlers.h -*- C++ -*- +/* + +Copyright (C) 1992, 1993 John W. Eaton + +This file is part of Octave. + +Octave is free software; you can redistribute it and/or modify it +under the terms of the GNU General Public License as published by the +Free Software Foundation; either version 2, or (at your option) any +later version. + +Octave is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +for more details. + +You should have received a copy of the GNU General Public License +along with Octave; see the file COPYING. If not, write to the Free +Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. + +*/ + +#if !defined (_sighandlers_h) +#define _sighandlers_h 1 + +#ifdef __GNUG__ +#pragma interface +#endif + +// Nonzero means we have already printed a message for this series of +// SIGPIPES. We assume that the writer will eventually give up. +extern int pipe_handler_error_count; + +// Nonzero means we can be interrupted. +extern int can_interrupt; + +typedef RETSIGTYPE sig_handler (...); + +extern void install_signal_handlers (void); + +#endif + +/* +;;; Local Variables: *** +;;; mode: C++ *** +;;; page-delimiter: "^/\\*" *** +;;; End: *** +*/
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/svd.cc Sun Aug 08 01:13:40 1993 +0000 @@ -0,0 +1,149 @@ +// tc-svd.cc -*- C++ -*- +/* + +Copyright (C) 1993 John W. Eaton + +This file is part of Octave. + +Octave is free software; you can redistribute it and/or modify it +under the terms of the GNU General Public License as published by the +Free Software Foundation; either version 2, or (at your option) any +later version. + +Octave is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +for more details. + +You should have received a copy of the GNU General Public License +along with Octave; see the file COPYING. If not, write to the Free +Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. + +*/ + +#ifdef __GNUG__ +#pragma implementation +#endif + +#include "Matrix.h" + +#include "tree-const.h" +#include "user-prefs.h" +#include "gripes.h" +#include "error.h" + +#ifdef WITH_DLD +tree_constant * +builtin_svd_2 (tree_constant *args, int nargin, int nargout) +{ + return svd (args, nargin, nargout); +} +#endif + +tree_constant * +svd (tree_constant *args, int nargin, int nargout) +{ + tree_constant *retval = NULL_TREE_CONST; + + tree_constant arg = args[1].make_numeric (); + + if (arg.rows () == 0 || arg.columns () == 0) + { + int flag = user_pref.propagate_empty_matrices; + if (flag != 0) + { + if (flag < 0) + gripe_empty_arg ("svd", 0); + Matrix m; + retval = new tree_constant [4]; + retval[0] = tree_constant (m); + retval[1] = tree_constant (m); + retval[2] = tree_constant (m); + } + else + gripe_empty_arg ("svd", 1); + + return retval; + } + + Matrix tmp; + ComplexMatrix ctmp; + switch (arg.const_type ()) + { + case tree_constant_rep::scalar_constant: + tmp.resize (1, 1); + tmp.elem (0, 0) = arg.double_value (); + break; + case tree_constant_rep::matrix_constant: + tmp = arg.matrix_value (); + break; + case tree_constant_rep::complex_scalar_constant: + ctmp.resize (1, 1); + ctmp.elem (0, 0) = arg.complex_value (); + break; + case tree_constant_rep::complex_matrix_constant: + ctmp = arg.complex_matrix_value (); + break; + default: + panic_impossible (); + break; + } + + switch (arg.const_type ()) + { + case tree_constant_rep::scalar_constant: + case tree_constant_rep::matrix_constant: + { + SVD result (tmp); + + DiagMatrix sigma = result.singular_values (); + + if (nargout == 1) + { + retval = new tree_constant [2]; + retval[0] = tree_constant (sigma.diag (), 1); + } + else + { + retval = new tree_constant [4]; + retval[0] = tree_constant (result.left_singular_matrix ()); + retval[1] = tree_constant (sigma); + retval[2] = tree_constant (result.right_singular_matrix ()); + } + } + break; + case tree_constant_rep::complex_scalar_constant: + case tree_constant_rep::complex_matrix_constant: + { + ComplexSVD result (ctmp); + + DiagMatrix sigma = result.singular_values (); + + if (nargout == 1) + { + retval = new tree_constant [2]; + retval[0] = tree_constant (sigma.diag (), 1); + } + else + { + retval = new tree_constant [4]; + retval[0] = tree_constant (result.left_singular_matrix ()); + retval[1] = tree_constant (sigma); + retval[2] = tree_constant (result.right_singular_matrix ()); + } + } + break; + default: + panic_impossible (); + break; + } + + return retval; +} + +/* +;;; Local Variables: *** +;;; mode: C++ *** +;;; page-delimiter: "^/\\*" *** +;;; End: *** +*/
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/symtab.cc Sun Aug 08 01:13:40 1993 +0000 @@ -0,0 +1,855 @@ +// Symbol table classes. -*- C++ -*- +/* + +Copyright (C) 1992, 1993 John W. Eaton + +This file is part of Octave. + +Octave is free software; you can redistribute it and/or modify it +under the terms of the GNU General Public License as published by the +Free Software Foundation; either version 2, or (at your option) any +later version. + +Octave is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +for more details. + +You should have received a copy of the GNU General Public License +along with Octave; see the file COPYING. If not, write to the Free +Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. + +*/ + +#ifdef __GNUG__ +#pragma implementation +#endif + +// Don't even think about moving the tree.h include to symtab.h... + +#include "symtab.h" +#include "error.h" +#include "variables.h" +#include "utils.h" +#include "tree.h" +#include "tree-const.h" + +/* + * Variables and functions. + */ +symbol_def::symbol_def (void) +{ + help_string = (char *) NULL; + type = unknown_type; + lifespan = temporary; + sym_class = read_write; + definition = (tree *) NULL; +} + +symbol_def::symbol_def (tree_constant *t) +{ + help_string = (char *) NULL; + type = variable; + lifespan = temporary; + sym_class = read_write; + definition = t; +} + +symbol_def::symbol_def (tree_builtin *t) +{ + help_string = (char *) NULL; + type = builtin_function; + lifespan = temporary; + sym_class = read_write; + definition = t; +} + +symbol_def::symbol_def (tree_function *t) +{ + help_string = (char *) NULL; + type = user_function; + lifespan = temporary; + sym_class = read_write; + definition = t; +} + +symbol_def::~symbol_def (void) +{ + delete [] help_string; + delete definition; +} + +void +symbol_def::define (tree_constant *t) +{ + definition = t; + type = variable; +} + +void +symbol_def::define (tree_builtin *t) +{ + definition = t; + type = builtin_function; +} + +void +symbol_def::define (tree_function *t) +{ + definition = t; + type = user_function; +} + +tree * +symbol_def::def (void) +{ + return definition; +} + +char * +symbol_def::help (void) +{ + return help_string; +} + +void +symbol_def::document (char *h) +{ + delete [] help_string; + help_string = strsave (h); +} + +int +symbol_def::save (ostream& os, int mark_as_global) +{ + return definition->save (os, mark_as_global); +} + +/* + * Individual records in a symbol table. + */ +symbol_record::symbol_record (void) +{ + nm = (char *) NULL; + formal_param = 0; + var = (symbol_def *) NULL; + fcn = (symbol_def *) NULL; + sv_fcn = (sv_Function) NULL; + next_elem = (symbol_record *) NULL; +} + +symbol_record::symbol_record (char *n) +{ + nm = strsave (n); + formal_param = 0; + var = (symbol_def *) NULL; + fcn = (symbol_def *) NULL; + sv_fcn = (sv_Function) NULL; + next_elem = (symbol_record *) NULL; +} + +symbol_record::symbol_record (char *n, symbol_record *nxt) +{ + nm = strsave (n); + formal_param = 0; + var = (symbol_def *) NULL; + fcn = (symbol_def *) NULL; + sv_fcn = (sv_Function) NULL; + next_elem = nxt; +} + +symbol_record::~symbol_record (void) +{ + delete [] nm; + + if (var != (symbol_def *) NULL && --var->count <= 0) + delete var; + + if (fcn != (symbol_def *) NULL && --fcn->count <= 0) + delete fcn; +} + +char * +symbol_record::name (void) +{ + return nm; +} + +char * +symbol_record::help (void) +{ + if (var != (symbol_def *) NULL) + return var->help (); + else if (fcn != (symbol_def *) NULL) + return fcn->help (); + else + return (char *) NULL; +} + +tree * +symbol_record::def (void) +{ + if (var != (symbol_def *) NULL) + return var->def (); + else if (fcn != (symbol_def *) NULL) + return fcn->def (); + else + return (tree *) NULL; +} + +int +symbol_record::is_function (void) +{ + return (var == (symbol_def *) NULL && fcn != (symbol_def *) NULL); +} + +int +symbol_record::is_variable (void) +{ + return (var != (symbol_def *) NULL); +} + +int +symbol_record::is_defined (void) +{ + return (var != (symbol_def *) NULL || fcn != (symbol_def *) NULL); +} + +void +symbol_record::set_sv_function (sv_Function f) +{ + sv_fcn = f; +} + +int +symbol_record::var_read_only (void) +{ + if (var != (symbol_def *) NULL + && var->sym_class == symbol_def::read_only) + { + error ("can't assign to read only symbol `%s'", nm); + return 1; + } + else + return 0; +} + +int +symbol_record::read_only (void) +{ + if ((var != (symbol_def *) NULL + && var->sym_class == symbol_def::read_only) + || (fcn != (symbol_def *) NULL + && fcn->sym_class == symbol_def::read_only)) + { + error ("can't assign to read only symbol `%s'", nm); + return 1; + } + else + return 0; +} + +int +symbol_record::define (tree_constant *t) +{ + if (var_read_only ()) + return 0; + + tree_constant *saved_def = NULL_TREE_CONST; + + if (var != (symbol_def *) NULL) + { + saved_def = (tree_constant *) var->def (); // XXX FIXME XXX + var->define (t); + } + else + { + var = new symbol_def (t); + var->count = 1; + } + + if (sv_fcn != (sv_Function) NULL && sv_fcn () < 0) + { + var->define (saved_def); + delete t; + return 0; + } + + delete saved_def; + + return 1; +} + +int +symbol_record::define (tree_builtin *t) +{ + if (read_only ()) + return 0; + + if (var != (symbol_def *) NULL) + { + if (--var->count <= 0) + delete var; + var = (symbol_def *) NULL; + } + + if (fcn != (symbol_def *) NULL) + fcn->define (t); + else + { + fcn = new symbol_def (t); + fcn->count = 1; + } + + return 1; +} + +int +symbol_record::define (tree_function *t) +{ + if (read_only ()) + return 0; + + if (var != (symbol_def *) NULL) + { + if (--var->count <= 0) + delete var; + var = (symbol_def *) NULL; + } + + if (fcn != (symbol_def *) NULL) + fcn->define (t); + else + { + fcn = new symbol_def (t); + fcn->count = 1; + } + + return 1; +} + +int +symbol_record::define_as_fcn (tree_constant *t) +{ + if (read_only ()) + return 0; + + if (var != (symbol_def *) NULL) + { + if (--var->count <= 0) + delete var; + var = (symbol_def *) NULL; + } + + if (fcn != (symbol_def *) NULL) + fcn->define (t); + else + { + fcn = new symbol_def (t); + fcn->count = 1; + } + + return 1; +} + +void +symbol_record::document (char *h) +{ + if (var != (symbol_def *) NULL) + var->document (h); + else if (fcn != (symbol_def *) NULL) + fcn->document (h); + else + warning ("couldn't document undefined variable `%s'", nm); +} + +void +symbol_record::protect (void) +{ + if (var != (symbol_def *) NULL) + var->sym_class = symbol_def::read_only; + else if (fcn != (symbol_def *) NULL) + fcn->sym_class = symbol_def::read_only; + else + warning ("couldn't protect undefined variable `%s'", nm); +} + +void +symbol_record::unprotect (void) +{ + if (var != (symbol_def *) NULL) + var->sym_class = symbol_def::read_write; + else if (fcn != (symbol_def *) NULL) + fcn->sym_class = symbol_def::read_write; +} + +void +symbol_record::make_eternal (void) +{ + if (var != (symbol_def *) NULL) + var->lifespan = symbol_def::eternal; + else if (fcn != (symbol_def *) NULL) + fcn->lifespan = symbol_def::eternal; + else + warning ("couldn't give eternal life to the variable `%s'", nm); +} + +int +symbol_record::save (ostream& os, int mark_as_global = 0) +{ + int status = 0; + + if (var != (symbol_def *) NULL && var->def () != (tree *) NULL) + { +// For now, eternal implies builtin. + if (var->lifespan != symbol_def::eternal) + { +// Should we also save the help string? Maybe someday. + os << "# name: " << nm << "\n"; + status = var->save (os, mark_as_global); + } + } + else if (fcn != (symbol_def *) NULL) + message ("save", "sorry, can't save functions yet"); + else + message ("save", "can't save undefined symbols!"); + + return status; +} + +void +symbol_record::clear_visible (void) +{ + if (var != (symbol_def *) NULL && var->lifespan != symbol_def::eternal) + { + if (--var->count <= 0) + delete var; + var = (symbol_def *) NULL; + } + else if (fcn != (symbol_def *) NULL && fcn->lifespan != symbol_def::eternal) + { + if (--fcn->count <= 0) + delete fcn; + fcn = (symbol_def *) NULL; + } +} + +void +symbol_record::clear_all (void) +{ + if (var != (symbol_def *) NULL && var->lifespan != symbol_def::eternal) + { + if (--var->count <= 0) + delete var; + var = (symbol_def *) NULL; + } + + if (fcn != (symbol_def *) NULL && fcn->lifespan != symbol_def::eternal) + { + if (--fcn->count <= 0) + delete fcn; + fcn = (symbol_def *) NULL; + } +} + +void +symbol_record::undefine (void) +{ + if (var != (symbol_def *) NULL) + { + if (--var->count <= 0) + delete var; + var = (symbol_def *) NULL; + } + + if (fcn != (symbol_def *) NULL) + { + if (--fcn->count <= 0) + delete fcn; + fcn = (symbol_def *) NULL; + } +} + +void +symbol_record::mark_as_formal_parameter (void) +{ + formal_param = 1; +} + +int +symbol_record::is_formal_parameter (void) +{ + return formal_param; +} + +void +symbol_record::alias (symbol_record *s, int force = 0) +{ + sv_fcn = s->sv_fcn; // Maybe this should go in the var symbol_def? + + formal_param = s->formal_param; // Hmm. + + if (force && s->var == (symbol_def *) NULL + && s->fcn == (symbol_def *) NULL) + { + s->var = new symbol_def (); + var = s->var; + var->count = 2; // Yes, this is correct. + return; + } + + if (s->var != (symbol_def *) NULL) + { + var = s->var; + var->count++; + } + else if (s->fcn != (symbol_def *) NULL) + { + fcn = s->fcn; + fcn->count++; + } +} + +symbol_record * +symbol_record::next (void) +{ + return next_elem; +} + +/* + * A symbol table. + */ + +symbol_table::symbol_table (void) +{ +} + +symbol_record * +symbol_table::lookup (char *nm, int insert = 0, int warn = 0) +{ + int index = hash (nm) & HASH_MASK; + + symbol_record *ptr = table[index].next (); + + while (ptr != (symbol_record *) NULL) + { + if (strcmp (ptr->name (), nm) == 0) + return ptr; + ptr = ptr->next (); + } + + if (insert) + { + symbol_record *new_sym; + new_sym = new symbol_record (nm, table[index].next ()); + table[index].next_elem = new_sym; + return new_sym; + } + else if (warn) + message ("lookup", "symbol`%s' not found", nm); + + return (symbol_record *) NULL; +} + +void +symbol_table::clear (void) +{ + for (int i = 0; i < HASH_TABLE_SIZE; i++) + { + symbol_record *prev = &table[i]; + symbol_record *curr = prev->next (); + + while (curr != (symbol_record *) NULL) + { + curr->clear_all (); + +// This record might have been read only. If so, we shouldn't delete +// it from the table. + if (curr->is_defined ()) + { + prev = curr; + curr = curr->next (); + } + else + { + prev->next_elem = curr->next (); + symbol_record *tmp = curr; + curr = curr->next (); + delete tmp; + } + } + } +} + +int +symbol_table::clear (char *nm) +{ + int index = hash (nm) & HASH_MASK; + + symbol_record *prev = &table[index]; + symbol_record *curr = prev->next (); + + while (curr != (symbol_record *) NULL) + { + if (strcmp (curr->name (), nm) == 0) + { + curr->clear_visible (); + + if (! curr->is_defined ()) + { + prev->next_elem = curr->next (); + symbol_record *tmp = curr; + curr = curr->next (); + delete tmp; + } + + return 1; + } + prev = curr; + curr = curr->next (); + } + + return 0; +} + +void +symbol_table::undefine (void) +{ + for (int i = 0; i < HASH_TABLE_SIZE; i++) + { + symbol_record *ptr = table[i].next (); + + while (ptr != (symbol_record *) NULL) + { + ptr->undefine (); + ptr = ptr->next (); + } + } +} + +// Ugh. + +void +symbol_table::bind_globals (void) +{ + assert (this != global_sym_tab); + + for (int i = 0; i < HASH_TABLE_SIZE; i++) + { + symbol_record *ptr = table[i].next (); + + while (ptr != (symbol_record *) NULL && ! ptr->formal_param) + { + char *nm = ptr->name (); + symbol_record *sr = global_sym_tab->lookup (nm, 0, 0); + if (sr != (symbol_record *) NULL) + ptr->alias (sr, 1); + ptr = ptr->next (); + } + } +} + +int +symbol_table::save (ostream& os, int mark_as_global = 0) +{ + int status = 0; + for (char **names = sorted_var_list (); *names != (char *) NULL; names++) + { + if (save (os, *names, mark_as_global)) + status++; + } + return status; +} + +int +symbol_table::save (ostream& os, char *name, int mark_as_global = 0) +{ + int status = 0; + symbol_record *sr = lookup (name, 0, 0); + if (sr != (symbol_record *) NULL) + status = sr->save (os, mark_as_global); + return status; +} + +int +symbol_table::size (void) +{ + int count = 0; + for (int i = 0; i < HASH_TABLE_SIZE; i++) + { + symbol_record *ptr = table[i].next (); + while (ptr != (symbol_record *) NULL) + { + count++; + ptr = ptr->next (); + } + } + return count; +} + +char ** +symbol_table::list (void) +{ + int count; + return list (count); +} + +char ** +symbol_table::var_list (void) +{ + int count; + return var_list (count); +} + +char ** +symbol_table::fcn_list (void) +{ + int count; + return fcn_list (count); +} + +char ** +symbol_table::list (int& count) +{ + int n = size (); + if (n == 0) + return (char **) NULL; + + char **symbols = new char * [n+1]; + count = 0; + for (int i = 0; i < HASH_TABLE_SIZE; i++) + { + symbol_record *ptr = table[i].next (); + while (ptr != (symbol_record *) NULL) + { + assert (count < n); + symbols[count++] = strsave (ptr->name ()); + ptr = ptr->next (); + } + } + symbols[count] = (char *) NULL; + return symbols; +} + +char ** +symbol_table::var_list (int& count) +{ + int n = size (); + if (n == 0) + return (char **) NULL; + + char **symbols = new char * [n+1]; + count = 0; + for (int i = 0; i < HASH_TABLE_SIZE; i++) + { + symbol_record *ptr = table[i].next (); + while (ptr != (symbol_record *) NULL) + { + assert (count < n); + if (ptr->is_variable ()) + symbols[count++] = strsave (ptr->name ()); + ptr = ptr->next (); + } + } + symbols[count] = (char *) NULL; + return symbols; +} + +char ** +symbol_table::fcn_list (int& count) +{ + int n = size (); + if (n == 0) + return (char **) NULL; + + char **symbols = new char * [n+1]; + count = 0; + for (int i = 0; i < HASH_TABLE_SIZE; i++) + { + symbol_record *ptr = table[i].next (); + while (ptr != (symbol_record *) NULL) + { + assert (count < n); + if (ptr->is_function ()) + symbols[count++] = strsave (ptr->name ()); + ptr = ptr->next (); + } + } + symbols[count] = (char *) NULL; + return symbols; +} + +static inline int +pstrcmp (char **a, char **b) +{ + return strcmp (*a, *b); +} + +char ** +symbol_table::sorted_list (void) +{ + int count = 0; + return sorted_list (count); +} + +char ** +symbol_table::sorted_var_list (void) +{ + int count = 0; + return sorted_var_list (count); +} + +char ** +symbol_table::sorted_fcn_list (void) +{ + int count = 0; + return sorted_fcn_list (count); +} + +char ** +symbol_table::sorted_list (int& count) +{ + char **symbols = list (count); + if (symbols != (char **) NULL) + qsort ((void **) symbols, count, sizeof (char *), + (int (*)(void*, void*)) pstrcmp); + return symbols; +} + +char ** +symbol_table::sorted_var_list (int& count) +{ + char **symbols = var_list (count); + if (symbols != (char **) NULL) + qsort ((void **) symbols, count, sizeof (char *), + (int (*)(void*, void*)) pstrcmp); + return symbols; +} + +char ** +symbol_table::sorted_fcn_list (int& count) +{ + char **symbols = fcn_list (count); + if (symbols != (char **) NULL) + qsort ((void **) symbols, count, sizeof (char *), + (int (*)(void*, void*)) pstrcmp); + return symbols; +} + +// Chris Torek's fave hash function. + +unsigned int +symbol_table::hash (const char *str) +{ + unsigned h = 0; + while (*str) + h = h * 33 + *str++; + return h; +} + +/* +;;; Local Variables: *** +;;; mode: C++ *** +;;; page-delimiter: "^/\\*" *** +;;; End: *** +*/
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/sysdep.cc Sun Aug 08 01:13:40 1993 +0000 @@ -0,0 +1,71 @@ +// sysdep.cc -*- C++ -*- +/* + +Copyright (C) 1993 John W. Eaton + +This file is part of Octave. + +Octave is free software; you can redistribute it and/or modify it +under the terms of the GNU General Public License as published by the +Free Software Foundation; either version 2, or (at your option) any +later version. + +Octave is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +for more details. + +You should have received a copy of the GNU General Public License +along with Octave; see the file COPYING. If not, write to the Free +Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. + +*/ + +#ifdef __GNUG__ +#pragma implementation +#endif + +#include <stdlib.h> + +#include "error.h" + +#ifdef NeXT +extern "C" +{ + typedef void (*_cplus_fcn_int) (int); + extern void (*malloc_error (_cplus_fcn_int)) (int); +} + +static void +malloc_handler (int code) +{ + if (code == 5) + message ("malloc_handler", + "hopefully recoverable malloc error: freeing wild pointer"); + else + { + panic ("probably irrecoverable malloc error: code %d", code); + } +} + +static void +NeXT_init (void) +{ + malloc_error (malloc_handler); +} +#endif + +void +sysdep_init (void) +{ +#ifdef NeXT + NeXT_init (); +#endif +} + +/* +;;; Local Variables: *** +;;; mode: C++ *** +;;; page-delimiter: "^/\\*" *** +;;; End: *** +*/
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/sysdep.h Sun Aug 08 01:13:40 1993 +0000 @@ -0,0 +1,36 @@ +// sysdep.h -*- C++ -*- +/* + +Copyright (C) 1992, 1993 John W. Eaton + +This file is part of Octave. + +Octave is free software; you can redistribute it and/or modify it +under the terms of the GNU General Public License as published by the +Free Software Foundation; either version 2, or (at your option) any +later version. + +Octave is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +for more details. + +You should have received a copy of the GNU General Public License +along with Octave; see the file COPYING. If not, write to the Free +Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. + +*/ + +#if !defined (_sysdep_h) +#define _sysdep_h 1 + +extern void sysdep_init (void); + +#endif + +/* +;;; Local Variables: *** +;;; mode: C++ *** +;;; page-delimiter: "^/\\*" *** +;;; End: *** +*/
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/t-builtins.cc Sun Aug 08 01:13:40 1993 +0000 @@ -0,0 +1,863 @@ +// t-builtins.cc -*- C++ -*- +/* + +Copyright (C) 1992, 1993 John W. Eaton + +This file is part of Octave. + +Octave is free software; you can redistribute it and/or modify it +under the terms of the GNU General Public License as published by the +Free Software Foundation; either version 2, or (at your option) any +later version. + +Octave is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +for more details. + +You should have received a copy of the GNU General Public License +along with Octave; see the file COPYING. If not, write to the Free +Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. + +*/ + +/* + +The function builtin_cd was adapted from a similar function from GNU +Bash, the Bourne Again SHell, copyright (C) 1987, 1989, 1991 Free +Software Foundation, Inc. + +The function list_in_columns was adapted from a similar function from +GNU ls, print_many_per_line, copyright (C) 1985, 1988, 1990, 1991 Free +Software Foundation, Inc. + +*/ + +#ifdef __GNUG__ +#pragma implementation +#endif + +#include <sys/types.h> +#ifdef HAVE_UNISTD_H +#include <unistd.h> +#endif +#include <iostream.h> +#include <strstream.h> +#include <fstream.h> +#include <stdio.h> +#include <fcntl.h> +#include <sys/file.h> +#include <sys/stat.h> +#include <time.h> +#include <errno.h> + +#include "procstream.h" + +#include "variables.h" +#include "symtab.h" +#include "error.h" +#include "input.h" +#include "pager.h" +#include "utils.h" +#include "builtins.h" +#include "t-builtins.h" +#include "octave.h" +#include "octave-hist.h" +#include "user-prefs.h" +#include "pr-output.h" +#include "tree.h" +#include "help.h" + +// May need replacement for this on some machines. +extern "C" +{ + extern char *strerror (int); + char *tilde_expand (char *s); /* From readline's tilde.c */ +} + +extern int symbol_out_of_date (symbol_record *s); + +// Is this a parametric plot? Makes a difference for 3D plotting. +extern int parametric_plot; + +/* + * Format a list in neat columns. Mostly stolen from GNU ls. This + * should maybe be in utils.cc. + */ +static ostrstream& +list_in_columns (ostrstream& os, char **list) +{ +// Compute the maximum name length. + + int max_name_length = 0; + int total_names = 0; + for (char **names = list; *names != (char *) NULL; names++) + { + total_names++; + int name_length = strlen (*names); + if (name_length > max_name_length) + max_name_length = name_length; + } + +// Allow at least two spaces between names. + + max_name_length += 2; + +// Calculate the maximum number of columns that will fit. + + int line_length = terminal_columns (); + int cols = line_length / max_name_length; + if (cols == 0) + cols = 1; + +// Calculate the number of rows that will be in each column except +// possibly for a short column on the right. + + int rows = total_names / cols + (total_names % cols != 0); + +// Recalculate columns based on rows. + + cols = total_names / rows + (total_names % rows != 0); + + names = list; + int count; + for (int row = 0; row < rows; row++) + { + count = row; + int pos = 0; + +// Print the next row. + + while (1) + { + os << *(names + count); + int name_length = strlen (*(names + count)); + + count += rows; + if (count >= total_names) + break; + + int spaces_to_pad = max_name_length - name_length; + for (int i = 0; i < spaces_to_pad; i++) + os << " "; + pos += max_name_length; + } + os << "\n"; + } + + return os; +} + +tree_constant +builtin_casesen (int argc, char **argv) +{ + tree_constant retval; + + if (argc == 1 || (argc > 1 && strcmp (argv[1], "off") == 0)) + message ("casesen", "sorry, octave is always case sensitive"); + else if (argc > 1 && strcmp (argv[1], "on") == 0) + ; // ok. + else + usage ("casesen [on|off]"); + + return retval; +} + +/* + * Change current working directory. + */ +tree_constant +builtin_cd (int argc, char **argv) +{ + tree_constant retval; + + if (argc > 1) + { + static char *dirname = (char *) NULL; + + if (dirname) + free (dirname); + + dirname = tilde_expand (argv[1]); + + if (dirname != (char *) NULL && !change_to_directory (dirname)) + { + error ("%s: %s", dirname, strerror (errno)); + return retval; + } + } + else + { + if (!home_directory) + return retval; + + if (!change_to_directory (home_directory)) + { + error ("%s: %s", home_directory, strerror (errno)); + return retval; + } + } + + + char *directory = get_working_directory ("cd"); + tree_constant *dir = new tree_constant (directory); + bind_protected_variable ("PWD", dir); + + return retval; +} + +/* + * Wipe out user-defined variables and functions. + */ +tree_constant +builtin_clear (int argc, char **argv) +{ + tree_constant retval; + if (argc == 1) + { + curr_sym_tab->clear (); + global_sym_tab->clear (); + } + else + { + while (--argc > 0) + { + argv++; + if (*argv != (char *) NULL && ! curr_sym_tab->clear (*argv)) + global_sym_tab->clear (*argv); + } + } + return retval; +} + +/* + * Associate a cryptic message with a variable name. + */ +tree_constant +builtin_document (int argc, char **argv) +{ + tree_constant retval; + if (argc == 3) + { + symbol_record *sym_rec = curr_sym_tab->lookup (argv[1], 0); + if (sym_rec == (symbol_record *) NULL) + { + sym_rec = global_sym_tab->lookup (argv[1], 0); + if (sym_rec == (symbol_record *) NULL) + { + error ("document: no such symbol `%s'", argv[1]); + return retval; + } + } + sym_rec->document (argv[2]); + } + else + usage ("document symbol string ..."); + + return retval; +} + +/* + * Edit commands with your favorite editor. + */ +tree_constant +builtin_edit_history (int argc, char **argv) +{ + tree_constant retval; + do_edit_history (argc, argv); + return retval; +} + +/* + * Set output format state. + */ +tree_constant +builtin_format (int argc, char **argv) +{ + tree_constant retval; + set_format_style (argc, argv); + return retval; +} + +/* + * Print cryptic yet witty messages. + */ +tree_constant +builtin_help (int argc, char **argv) +{ + tree_constant retval; + + ostrstream output_buf; + if (argc == 1) + { + char **symbols; + int count = 0; + + symbols = names (operator_help (), count); + output_buf << "\n*** operators:\n\n"; + if (symbols != (char **) NULL && count > 0) + list_in_columns (output_buf, symbols); + delete [] symbols; + + symbols = names (keyword_help (), count); + output_buf << "\n*** reserved words:\n\n"; + if (symbols != (char **) NULL && count > 0) + list_in_columns (output_buf, symbols); + delete [] symbols; + + symbols = names (builtin_text_functions_help (), count); + output_buf + << "\n*** text functions (these names are also reserved):\n\n"; + if (symbols != (char **) NULL && count > 0) + list_in_columns (output_buf, symbols); + delete [] symbols; + + symbols = names (builtin_mapper_functions_help (), count); + output_buf << "\n*** mapper functions:\n\n"; + if (symbols != (char **) NULL && count > 0) + list_in_columns (output_buf, symbols); + delete [] symbols; + + symbols = names (builtin_general_functions_help (), count); + output_buf << "\n*** general functions:\n\n"; + if (symbols != (char **) NULL && count > 0) + list_in_columns (output_buf, symbols); + delete [] symbols; + + symbols = names (builtin_variables_help (), count); + output_buf << "\n*** builtin variables:\n\n"; + if (symbols != (char **) NULL && count > 0) + list_in_columns (output_buf, symbols); + delete [] symbols; + +// Also need to list variables and currently compiled functions from +// the symbol table, if there are any. + +// Also need to search octave_path for script files. + + char **path = pathstring_to_vector (user_pref.loadpath); + + char **ptr = path; + if (ptr != (char **) NULL) + { + while (*ptr != (char *) NULL) + { + int count; + char **names = get_m_file_names (count, *ptr, 0); + output_buf << "\n*** M-files in " + << make_absolute (*ptr, the_current_working_directory) + << ":\n\n"; + if (names != (char **) NULL && count > 0) + list_in_columns (output_buf, names); + delete [] names; + ptr++; + } + } + } + else + { + symbol_record *sym_rec; + help_list *op_help_list = operator_help (); + help_list *kw_help_list = keyword_help (); + for (int i = 1; i < argc; i++) + { + if (argv[i] == (char *) NULL || argv[i][0] == '\0') + continue; + + int j = 0; + char *name; + while ((name = op_help_list[j].name) != (char *) NULL) + { + if (strcmp (name, argv[i]) == 0) + { + output_buf << "\n" << op_help_list[j].help << "\n"; + goto next; + } + j++; + } + + j = 0; + while ((name = kw_help_list[j].name) != (char *) NULL) + { + if (strcmp (name, argv[i]) == 0) + { + output_buf << "\n" << kw_help_list[j].help << "\n"; + goto next; + } + j++; + } + + sym_rec = curr_sym_tab->lookup (argv[i], 0, 0); + if (sym_rec != (symbol_record *) NULL) + { + char *h = sym_rec->help (); + if (h != (char *) NULL && *h != '\0') + { + output_buf << "\n" << h << "\n"; + goto next; + } + } + + sym_rec = global_sym_tab->lookup (argv[i], 0, 0); + if (sym_rec != (symbol_record *) NULL + && ! symbol_out_of_date (sym_rec)) + { + char *h = sym_rec->help (); + if (h != (char *) NULL && *h != '\0') + { + output_buf << "\n" << h << "\n"; + goto next; + } + } + +// Try harder to find M-files that might not be defined yet, or that +// appear to be out of date. Don\'t execute commands from the file if +// it turns out to be a script file. + + sym_rec = global_sym_tab->lookup (argv[i], 1, 0); + if (sym_rec != (symbol_record *) NULL) + { + tree_identifier tmp (sym_rec); + tmp.parse_m_file (0); + char *h = sym_rec->help (); + if (h != (char *) NULL && *h != '\0') + { + output_buf << "\n" << h << "\n"; + goto next; + } + } + else + global_sym_tab->clear (argv[i]); + + output_buf << "Sorry, `" << argv[i] << "' is not documented\n"; + + next: + continue; + } + } + + output_buf << ends; + maybe_page_output (output_buf); + + return retval; +} + +/* + * Display, save, or load history. + */ +tree_constant +builtin_history (int argc, char **argv) +{ + tree_constant retval; + + do_history (argc, argv); + + return retval; +} + +static int +load_variable (char *nm, int force, istream& is) +{ + symbol_record *gsr = global_sym_tab->lookup (nm, 0, 0); + symbol_record *lsr = curr_sym_tab->lookup (nm, 0, 0); + + if (! force + && ((gsr != (symbol_record *) NULL && gsr->is_variable ()) + || lsr != (symbol_record *) NULL)) + { + message ("load", + "variable name `%s' exists -- use `load -force' to overwrite", nm); + return -1; + } + +// We found it. Read data for this entry, and if that succeeds, +// insert it into symbol table. + + tree_constant tc; + int global = tc.load (is); + if (tc.const_type () != tree_constant_rep::unknown_constant) + { + symbol_record *sr; + if (global) + { + if (lsr != (symbol_record *) NULL) + { + warning ("load: replacing local symbol `%s' with global\ + value from file", nm); + curr_sym_tab->clear (nm); + } + sr = global_sym_tab->lookup (nm, 1, 0); + } + else + { + if (gsr != (symbol_record *) NULL) + { + warning ("loading `%s' as a global variable", nm); + sr = gsr; + } + else + sr = curr_sym_tab->lookup (nm, 1, 0); + } + + if (sr != (symbol_record *) NULL) + { + tree_constant *tmp_tc = new tree_constant (tc); + sr->define (tmp_tc); + return 1; + } + else + error ("load: unable to load variable `%s'", nm); + } + + return 0; +} + +/* + * Read variables from an input stream. + * + * BUGS: + * + * -- This function is not terribly robust. + * -- Symbols are only inserted into the current symbol table. + */ +tree_constant +builtin_load (int argc, char **argv) +{ + tree_constant retval; + + argc--; + argv++; + + int force = 0; + if (argc > 0 && strcmp (*argv, "-force") == 0) + { + force++; + argc--; + argv++; + } + + if (argc < 1) + { + message ("load", "you must specify a single file to read"); + return retval; + } + + static istream stream; + static ifstream file; + if (strcmp (*argv, "-") == 0) + { + stream = cin; + } + else + { + char *fname = tilde_expand (*argv); + file.open (fname); + if (! file) + { + error ("load: couldn't open input file `%s'", *argv); + return retval; + } + stream = file; + } + + char nm [128]; // XXX FIXME XXX + int count = 0; + for (;;) + { +// Read name for this entry or break on EOF. + if (extract_keyword (stream, "name", nm) == 0 || nm == (char *) NULL) + { + if (count == 0) + message ("load", + "no name keywords found. Are you sure this is an octave data file?"); + break; + } + + if (*nm == '\0') + continue; + + if (! valid_identifier (nm)) + { + message ("load", "skipping bogus identifier `%s'", nm); + continue; + } + + if (load_variable (nm, force, stream)) + count++; + } + + if (file); + file.close (); + + return retval; +} + +/* + * Get a directory listing. + */ +tree_constant +builtin_ls (int argc, char **argv) +{ + tree_constant retval; + + ostrstream ls_buf; + + ls_buf << "ls -C "; + for (int i = 1; i < argc; i++) + ls_buf << tilde_expand (argv[i]) << " "; + + ls_buf << ends; + + char *ls_command = ls_buf.str (); + + iprocstream cmd (ls_command); + + char ch; + ostrstream output_buf; + while (cmd.get (ch)) + output_buf.put (ch); + + output_buf << ends; + + maybe_page_output (output_buf); + + delete [] ls_command; + + return retval; +} + +/* + * Write variables to an output stream. + */ +tree_constant +builtin_save (int argc, char **argv) +{ + tree_constant retval; + + if (argc < 2) + { + usage ("save file -- save all variables in named file\n\ + save file var ... -- saved named variables"); + return retval; + } + + argc--; + argv++; + + static ostream stream; + static ofstream file; + if (strcmp (*argv, "-") == 0) + { +// XXX FIXME XXX -- things intended for the screen should end up in a +// tree_constant (string)? + stream = cout; + } + else + { + char *fname = tilde_expand (*argv); + file.open (fname); + if (! file) + { + error ("save: couldn't open output file `%s'", *argv); + return retval; + } + stream = file; + } + + if (argc == 1) + { + curr_sym_tab->save (stream); + global_sym_tab->save (stream, 1); + } + else + { + while (--argc > 0) + { + argv++; + if (! curr_sym_tab->save (stream, *argv)) + if (! global_sym_tab->save (stream, *argv, 1)) + { + message ("save", "no such variable `%s'", *argv); + continue; + } + } + } + + if (file); + file.close (); + + return retval; +} + +/* + * Set plotting options. + */ +tree_constant +builtin_set (int argc, char **argv) +{ + tree_constant retval; + + ostrstream plot_buf; + + if (argc > 1) + { + if (almost_match ("parametric", argv[1], 3)) + parametric_plot = 1; + else if (almost_match ("noparametric", argv[1], 5)) + parametric_plot = 0; + } + + for (int i = 0; i < argc; i++) + plot_buf << argv[i] << " "; + + plot_buf << "\n" << ends; + + char *plot_command = plot_buf.str (); + send_to_plot_stream (plot_command); + + delete [] plot_command; + + return retval; +} + +/* + * Set plotting options. + */ +tree_constant +builtin_show (int argc, char **argv) +{ + tree_constant retval; + + ostrstream plot_buf; + + for (int i = 0; i < argc; i++) + plot_buf << argv[i] << " "; + + plot_buf << "\n" << ends; + + char *plot_command = plot_buf.str (); + send_to_plot_stream (plot_command); + + delete [] plot_command; + + return retval; +} + +/* + * List variable names. + */ +tree_constant +builtin_who (int argc, char **argv) +{ + tree_constant retval; + int show_global = 0; + int show_local = 1; + int show_top = 0; + int show_fcns = 0; + + if (argc > 1) + show_local = 0; + + for (int i = 1; i < argc; i++) + { + argv++; + if (strcmp (*argv, "-all") == 0) + { + show_global++; + show_local++; + show_top++; + show_fcns++; + } + else if (strcmp (*argv, "-global") == 0) + show_global++; + else if (strcmp (*argv, "-local") == 0) + show_local++; + else if (strcmp (*argv, "-top") == 0) + show_top++; + else if (strcmp (*argv, "-fcn") == 0 + || strcmp (*argv, "-fcns") == 0 + || strcmp (*argv, "-functions") == 0) + show_fcns++; + else + { + message ("who", "unrecognized option `%s'", *argv); + if (argc == 2) + show_local = 1; + } + } + + ostrstream output_buf; + int pad_after = 0; + if (show_global) + { + int count = 0; + char **symbols = global_sym_tab->sorted_var_list (count); + if (symbols != (char **) NULL && count > 0) + { + output_buf << "\n*** global symbols:\n\n"; + list_in_columns (output_buf, symbols); + delete [] symbols; + pad_after++; + } + } + + if (show_top) + { + int count = 0; + char **symbols = top_level_sym_tab->sorted_var_list (count); + if (symbols != (char **) NULL && count > 0) + { + output_buf << "\n*** top level symbols:\n\n"; + list_in_columns (output_buf, symbols); + delete [] symbols; + pad_after++; + } + } + + if (show_local) + { + if (show_top && curr_sym_tab == top_level_sym_tab) + output_buf << + "\ncurrent (local) symbol table == top level symbol table\n"; + else + { + int count = 0; + char **symbols = curr_sym_tab->sorted_var_list (count); + if (symbols != (char **) NULL && count > 0) + { + output_buf << "\n*** local symbols:\n\n"; + list_in_columns (output_buf, symbols); + delete [] symbols; + pad_after++; + } + } + } + + if (show_fcns) + { + int count = 0; + char **symbols = global_sym_tab->sorted_fcn_list (count); + if (symbols != (char **) NULL && count > 0) + { + output_buf << "\n*** functions builtin or currently compiled:\n\n"; + list_in_columns (output_buf, symbols); + delete [] symbols; + pad_after++; + } + } + + if (pad_after) + output_buf << "\n"; + + output_buf << ends; + maybe_page_output (output_buf); + + return retval; +} + +/* +;;; Local Variables: *** +;;; mode: C++ *** +;;; page-delimiter: "^/\\*" *** +;;; End: *** +*/
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/t-builtins.h Sun Aug 08 01:13:40 1993 +0000 @@ -0,0 +1,63 @@ +// builtin text function support. -*- C++ -*- +/* + +Copyright (C) 1992, 1993 John W. Eaton + +This file is part of Octave. + +Octave is free software; you can redistribute it and/or modify it +under the terms of the GNU General Public License as published by the +Free Software Foundation; either version 2, or (at your option) any +later version. + +Octave is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +for more details. + +You should have received a copy of the GNU General Public License +along with Octave; see the file COPYING. If not, write to the Free +Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. + +*/ + +#if !defined (_t_builtins_h) +#define _t_builtins_h 1 + +#ifdef __GNUG__ +#pragma interface +#endif + +#include "tree-const.h" + +struct builtin_text_functions +{ + char *name; + int nargin_max; + Text_fcn text_fcn; + char *help_string; +}; + +extern tree_constant builtin_casesen (int, char **); +extern tree_constant builtin_cd (int, char **); +extern tree_constant builtin_clear (int, char **); +extern tree_constant builtin_document (int, char **); +extern tree_constant builtin_edit_history (int, char **); +extern tree_constant builtin_format (int, char **); +extern tree_constant builtin_help (int, char **); +extern tree_constant builtin_history (int, char **); +extern tree_constant builtin_load (int, char **); +extern tree_constant builtin_ls (int, char **); +extern tree_constant builtin_save (int, char **); +extern tree_constant builtin_set (int, char **); +extern tree_constant builtin_show (int, char **); +extern tree_constant builtin_who (int, char **); + +#endif + +/* +;;; Local Variables: *** +;;; mode: C++ *** +;;; page-delimiter: "^/\\*" *** +;;; End: *** +*/
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/tc-assign.cc Sun Aug 08 01:13:40 1993 +0000 @@ -0,0 +1,1420 @@ +// tc-assign.cc -*- C++ -*- +/* + +Copyright (C) 1992, 1993 John W. Eaton + +This file is part of Octave. + +Octave is free software; you can redistribute it and/or modify it +under the terms of the GNU General Public License as published by the +Free Software Foundation; either version 2, or (at your option) any +later version. + +Octave is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +for more details. + +You should have received a copy of the GNU General Public License +along with Octave; see the file COPYING. If not, write to the Free +Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. + +*/ + +#ifdef __GNUG__ +#pragma implementation +#endif + +#include "user-prefs.h" +#include "error.h" +#include "gripes.h" +#include "utils.h" +#include "tree-const.h" + +#include "tc-inlines.cc" + +void +tree_constant_rep::assign (tree_constant& rhs, tree_constant *args, int nargs) +{ + tree_constant rhs_tmp = rhs.make_numeric (); + + if (type_tag == string_constant || type_tag == range_constant) + force_numeric (); + + switch (type_tag) + { + case complex_scalar_constant: + case scalar_constant: + case unknown_constant: + do_scalar_assignment (rhs_tmp, args, nargs); + break; + case complex_matrix_constant: + case matrix_constant: + do_matrix_assignment (rhs_tmp, args, nargs); + break; + case string_constant: + error ("invalid assignment to string type"); + break; + case range_constant: + case magic_colon: + default: + panic_impossible (); + break; + } +} + +void +tree_constant_rep::do_scalar_assignment (tree_constant& rhs, + tree_constant *args, int nargs) +{ + assert (type_tag == unknown_constant + || type_tag == scalar_constant + || type_tag == complex_scalar_constant); + + if (rhs.is_scalar_type () && valid_scalar_indices (args, nargs)) + { + if (type_tag == unknown_constant || type_tag == scalar_constant) + { + if (rhs.const_type () == scalar_constant) + { + scalar = rhs.double_value (); + type_tag = scalar_constant; + } + else if (rhs.const_type () == complex_scalar_constant) + { + complex_scalar = new Complex (rhs.complex_value ()); + type_tag = complex_scalar_constant; + } + else + { + error ("invalid assignment to scalar"); + jump_to_top_level (); + } + } + else + { + if (rhs.const_type () == scalar_constant) + { + scalar = rhs.double_value (); + type_tag = scalar_constant; + } + else if (rhs.const_type () == complex_scalar_constant) + { + *complex_scalar = rhs.complex_value (); + type_tag = complex_scalar_constant; + } + else + { + error ("invalid assignment to scalar"); + jump_to_top_level (); + } + } + } + else if (user_pref.resize_on_range_error) + { + if (type_tag == complex_scalar_constant) + { + Complex *old_complex = complex_scalar; + complex_matrix = new ComplexMatrix (1, 1, *complex_scalar); + type_tag = complex_matrix_constant; + delete old_complex; + } + else if (type_tag == scalar_constant) + { + matrix = new Matrix (1, 1, scalar); + type_tag = matrix_constant; + } + do_matrix_assignment (rhs, args, nargs); + } + else if (nargs > 3 || nargs < 2) + { + error ("invalid index expression for scalar type"); + jump_to_top_level (); + } + else + { + error ("index invalid or out of range for scalar type"); + jump_to_top_level (); + } +} + +void +tree_constant_rep::do_matrix_assignment (tree_constant& rhs, + tree_constant *args, int nargs) +{ + assert (type_tag == unknown_constant + || type_tag == matrix_constant + || type_tag == complex_matrix_constant); + + if (type_tag == matrix_constant && rhs.is_complex_type ()) + { + Matrix *old_matrix = matrix; + complex_matrix = new ComplexMatrix (*matrix); + type_tag = complex_matrix_constant; + delete old_matrix; + } + else if (type_tag == unknown_constant) + { + if (rhs.is_complex_type ()) + { + complex_matrix = new ComplexMatrix (); + type_tag = complex_matrix_constant; + } + else + { + matrix = new Matrix (); + type_tag = matrix_constant; + } + } + + switch (nargs) + { + case 2: + if (args == NULL_TREE_CONST) + error ("matrix index is null"); + else if (args[1].is_undefined ()) + error ("matrix index is a null expression"); + else + do_matrix_assignment (rhs, args[1]); + break; + case 3: + if (args == NULL_TREE_CONST) + error ("matrix indices are null"); + else if (args[1].is_undefined ()) + error ("first matrix index is a null expression"); + else if (args[2].is_undefined ()) + error ("second matrix index is a null expression"); + else + do_matrix_assignment (rhs, args[1], args[2]); + break; + default: + error ("too many indices for matrix expression"); + break; + } +} + +void +tree_constant_rep::do_matrix_assignment (tree_constant& rhs, + tree_constant& i_arg) +{ + int nr = rows (); + int nc = columns (); + + if (user_pref.do_fortran_indexing) + fortran_style_matrix_assignment (rhs, i_arg); + else if (nr <= 1 || nc <= 1) + vector_assignment (rhs, i_arg); + else + error ("single index only valid for row or column vector"); +} + +void +tree_constant_rep::fortran_style_matrix_assignment (tree_constant& rhs, + tree_constant& i_arg) +{ + tree_constant tmp_i = i_arg.make_numeric_or_magic (); + + tree_constant_rep::constant_type itype = tmp_i.const_type (); + + int nr = rows (); + int nc = columns (); + + int rhs_nr = rhs.rows (); + int rhs_nc = rhs.columns (); + + switch (itype) + { + case complex_scalar_constant: + case scalar_constant: + { + int i = NINT (tmp_i.double_value ()); + index_check (i-1, ""); + if (nr <= 1 || nc <= 1) + maybe_resize (i-1); + else + range_max_check (i-1, nr * nc); + + nr = rows (); + nc = columns (); + + if (! indexed_assign_conforms (1, 1, rhs_nr, rhs_nc)) + { + error ("for A(int) = X: X must be a scalar"); + jump_to_top_level (); + } + int ii = fortran_row (i, nr) - 1; + int jj = fortran_column (i, nr) - 1; + do_matrix_assignment (rhs, ii, jj); + } + break; + case complex_matrix_constant: + case matrix_constant: + { + Matrix mi = tmp_i.matrix_value (); + int len = nr * nc; + idx_vector ii (mi, 1, "", len); // Always do fortran indexing here... + int imax = ii.max (); + + if (nr <= 1 || nc <= 1) + maybe_resize (imax-1); + else + range_max_check (imax-1, len); + + if (ii.capacity () != rhs_nr * rhs_nc) + { + error ("A(matrix) = X: X and matrix must have the same\ + number of elements"); + jump_to_top_level (); + } + fortran_style_matrix_assignment (rhs, ii); + } + break; + case string_constant: + gripe_string_invalid (); + break; + case range_constant: + gripe_range_invalid (); + break; + case magic_colon: + fortran_style_matrix_assignment (rhs, magic_colon); + break; + default: + panic_impossible (); + break; + } +} + +void +tree_constant_rep::vector_assignment (tree_constant& rhs, tree_constant& i_arg) +{ + int nr = rows (); + int nc = columns (); + + assert ((nr == 1 || nc == 1 || (nr == 0 && nc == 0)) + && ! user_pref.do_fortran_indexing); + + tree_constant tmp_i = i_arg.make_numeric_or_range_or_magic (); + + tree_constant_rep::constant_type itype = tmp_i.const_type (); + + switch (itype) + { + case complex_scalar_constant: + case scalar_constant: + { + int i = tree_to_mat_idx (tmp_i.double_value ()); + index_check (i, ""); + do_vector_assign (rhs, i); + } + break; + case complex_matrix_constant: + case matrix_constant: + { + Matrix mi = tmp_i.matrix_value (); + int len = nr * nc; + idx_vector iv (mi, user_pref.do_fortran_indexing, "", len); + do_vector_assign (rhs, iv); + } + break; + case string_constant: + gripe_string_invalid (); + break; + case range_constant: + { + Range ri = tmp_i.range_value (); + if (rows () == 2 && is_zero_one (ri)) + { + do_vector_assign (rhs, 1); + } + else + { + int imax; + index_check (ri, imax, ""); + do_vector_assign (rhs, ri, imax); + } + } + break; + case magic_colon: + { + int rhs_nr = rhs.rows (); + int rhs_nc = rhs.columns (); + + if (! indexed_assign_conforms (nr, nc, rhs_nr, rhs_nc)) + { + error ("A(:) = X: X and A must have the same dimensions"); + jump_to_top_level (); + } + do_matrix_assignment (rhs, magic_colon, magic_colon); + } + break; + default: + panic_impossible (); + break; + } +} + +void +tree_constant_rep::check_vector_assign (int rhs_nr, int rhs_nc, + int ilen, char *rm) +{ + int nr = rows (); + int nc = columns (); + + if (nr == 1 && nc == 1) // No orientation to preserve + { + if (! ( ilen == rhs_nr || ilen == rhs_nc)) + { + error ("A(%s) = X: X and %s must have the same number of\ + elements", rm, rm); + jump_to_top_level (); + } + } + else if (nr == 1) // Preserve current row orientation + { + if (! (rhs_nr == 1 && rhs_nc == ilen)) + { + error ("A(%s) = X: where A is a row vector, X must also be a\ + row vector with the same number of elements as %s", rm, rm); + jump_to_top_level (); + } + } + else if (nc == 1) // Preserve current column orientation + { + if (! (rhs_nc == 1 && rhs_nr == ilen)) + { + error ("A(%s) = X: where A is a column vector, X must also\ + be a column vector with the same number of elements as %s", rm, rm); + jump_to_top_level (); + } + } + else + panic_impossible (); +} + +void +tree_constant_rep::do_vector_assign (tree_constant& rhs, int i) +{ + int rhs_nr = rhs.rows (); + int rhs_nc = rhs.columns (); + + if (! indexed_assign_conforms (1, 1, rhs_nr, rhs_nc)) + { + error ("for A(int) = X: X must be a scalar"); + jump_to_top_level (); + } + + maybe_resize (i); + + int nr = rows (); + int nc = columns (); + + if (nr == 1) + { + REP_ELEM_ASSIGN (0, i, rhs.double_value (), rhs.complex_value (), + rhs.is_real_type ()); + } + else if (nc == 1) + { + REP_ELEM_ASSIGN (i, 0, rhs.double_value (), rhs.complex_value (), + rhs.is_real_type ()); + } + else + panic_impossible (); +} + +void +tree_constant_rep::do_vector_assign (tree_constant& rhs, idx_vector& iv) +{ + REP_RHS_MATRIX (rhs, rhs_m, rhs_cm, rhs_nr, rhs_nc); + + int ilen = iv.capacity (); + check_vector_assign (rhs_nr, rhs_nc, ilen, "matrix"); + + force_orient f_orient = no_orient; + if (rhs_nr == 1 && rhs_nc != 1) + f_orient = row_orient; + else if (rhs_nc == 1 && rhs_nr != 1) + f_orient = column_orient; + + maybe_resize (iv.max (), f_orient); + + int nr = rows (); + int nc = columns (); + + if (nr == 1) + { + for (int i = 0; i < iv.capacity (); i++) + REP_ELEM_ASSIGN (0, iv.elem (i), rhs_m.elem (0, i), + rhs_cm.elem (0, i), rhs.is_real_type ()); + } + else if (nc == 1) + { + for (int i = 0; i < iv.capacity (); i++) + REP_ELEM_ASSIGN (iv.elem (i), 0, rhs_m.elem (i, 0), + rhs_cm.elem (i, 0), rhs.is_real_type ()); + } + else + panic_impossible (); +} + +void +tree_constant_rep::do_vector_assign (tree_constant& rhs, Range& ri, int imax) +{ + REP_RHS_MATRIX (rhs, rhs_m, rhs_cm, rhs_nr, rhs_nc); + + int ilen = ri.nelem (); + check_vector_assign (rhs_nr, rhs_nc, ilen, "range"); + + force_orient f_orient = no_orient; + if (rhs_nr == 1 && rhs_nc != 1) + f_orient = row_orient; + else if (rhs_nc == 1 && rhs_nr != 1) + f_orient = column_orient; + + maybe_resize (imax, f_orient); + + int nr = rows (); + int nc = columns (); + + double b = ri.base (); + double increment = ri.inc (); + + if (nr == 1) + { + for (int i = 0; i < ri.nelem (); i++) + { + double tmp = b + i * increment; + int col = tree_to_mat_idx (tmp); + REP_ELEM_ASSIGN (0, col, rhs_m.elem (0, i), rhs_cm.elem (0, i), + rhs.is_real_type ()); + } + } + else if (nc == 1) + { + for (int i = 0; i < ri.nelem (); i++) + { + double tmp = b + i * increment; + int row = tree_to_mat_idx (tmp); + REP_ELEM_ASSIGN (row, 0, rhs_m.elem (i, 0), rhs_cm.elem (i, 0), + rhs.is_real_type ()); + } + } + else + panic_impossible (); +} + +void +tree_constant_rep::fortran_style_matrix_assignment + (tree_constant& rhs, tree_constant_rep::constant_type mci) +{ + assert (rhs.is_matrix_type ()); + assert (mci == tree_constant_rep::magic_colon); + + int nr = rows (); + int nc = columns (); + + REP_RHS_MATRIX (rhs, rhs_m, rhs_cm, rhs_nr, rhs_nc); + + int rhs_size = rhs_nr * rhs_nc; + if (rhs_size == 0) + { + if (rhs.const_type () == matrix_constant) + { + delete matrix; + matrix = new Matrix (0, 0); + return; + } + else + panic_impossible (); + } + else if (nr*nc != rhs_size) + { + error ("A(:) = X: X and A must have the same number of elements"); + jump_to_top_level (); + } + + if (rhs.const_type () == matrix_constant) + { + double *cop_out = rhs_m.fortran_vec (); + for (int j = 0; j < nc; j++) + for (int i = 0; i < nr; i++) + matrix->elem (i, j) = *cop_out++; + } + else + { + Complex *cop_out = rhs_cm.fortran_vec (); + for (int j = 0; j < nc; j++) + for (int i = 0; i < nr; i++) + complex_matrix->elem (i, j) = *cop_out++; + } +} + +void +tree_constant_rep::fortran_style_matrix_assignment (tree_constant& rhs, + idx_vector& i) +{ + assert (rhs.is_matrix_type ()); + + int ilen = i.capacity (); + + REP_RHS_MATRIX (rhs, rhs_m, rhs_cm, rhs_nr, rhs_nc); + + int len = rhs_nr * rhs_nc; + + if (len == ilen) + { + int nr = rows (); + if (rhs.const_type () == matrix_constant) + { + double *cop_out = rhs_m.fortran_vec (); + for (int k = 0; k < len; k++) + { + int ii = fortran_row (i.elem (k) + 1, nr) - 1; + int jj = fortran_column (i.elem (k) + 1, nr) - 1; + + matrix->elem (ii, jj) = *cop_out++; + } + } + else + { + Complex *cop_out = rhs_cm.fortran_vec (); + for (int k = 0; k < len; k++) + { + int ii = fortran_row (i.elem (k) + 1, nr) - 1; + int jj = fortran_column (i.elem (k) + 1, nr) - 1; + + complex_matrix->elem (ii, jj) = *cop_out++; + } + } + } + else + { + error ("number of rows and columns must match for indexed assignment"); + jump_to_top_level (); + } +} + +void +tree_constant_rep::do_matrix_assignment (tree_constant& rhs, + tree_constant& i_arg, + tree_constant& j_arg) +{ + tree_constant tmp_i = i_arg.make_numeric_or_range_or_magic (); + + tree_constant_rep::constant_type itype = tmp_i.const_type (); + +// index_check() and matrix_to_index_vector() jump to the top level on +// errors. + + switch (itype) + { + case complex_scalar_constant: + case scalar_constant: + { + int i = tree_to_mat_idx (tmp_i.double_value ()); + index_check (i, "row"); + do_matrix_assignment (rhs, i, j_arg); + } + break; + case complex_matrix_constant: + case matrix_constant: + { + Matrix mi = tmp_i.matrix_value (); + idx_vector iv (mi, user_pref.do_fortran_indexing, "row", rows ()); + do_matrix_assignment (rhs, iv, j_arg); + } + break; + case string_constant: + gripe_string_invalid (); + break; + case range_constant: + { + Range ri = tmp_i.range_value (); + if (rows () == 2 && is_zero_one (ri)) + { + do_matrix_assignment (rhs, 1, j_arg); + } + else + { + int imax; + index_check (ri, imax, "row"); + do_matrix_assignment (rhs, ri, imax, j_arg); + } + } + break; + case magic_colon: + do_matrix_assignment (rhs, magic_colon, j_arg); + break; + default: + panic_impossible (); + break; + } +} + +void +tree_constant_rep::do_matrix_assignment (tree_constant& rhs, int i, + tree_constant& j_arg) +{ + tree_constant tmp_j = j_arg.make_numeric_or_range_or_magic (); + + tree_constant_rep::constant_type jtype = tmp_j.const_type (); + + int rhs_nr = rhs.rows (); + int rhs_nc = rhs.columns (); + +// index_check() and matrix_to_index_vector() jump to the top level on +// errors. + + switch (jtype) + { + case complex_scalar_constant: + case scalar_constant: + { + int j = tree_to_mat_idx (tmp_j.double_value ()); + index_check (j, "column"); + if (! indexed_assign_conforms (1, 1, rhs_nr, rhs_nc)) + { + error ("A(int,int) = X, X must be a scalar"); + jump_to_top_level (); + } + maybe_resize (i, j); + do_matrix_assignment (rhs, i, j); + } + break; + case complex_matrix_constant: + case matrix_constant: + { + Matrix mj = tmp_j.matrix_value (); + idx_vector jv (mj, user_pref.do_fortran_indexing, "column", + columns ()); + if (! indexed_assign_conforms (1, jv.capacity (), rhs_nr, rhs_nc)) + { + error ("A(int,matrix) = X: X must be a row vector with the\ + same number of elements as matrix"); + jump_to_top_level (); + } + maybe_resize (i, jv.max ()); + do_matrix_assignment (rhs, i, jv); + } + break; + case string_constant: + gripe_string_invalid (); + break; + case range_constant: + { + Range rj = tmp_j.range_value (); + if (! indexed_assign_conforms (1, rj.nelem (), rhs_nr, rhs_nc)) + { + error ("A(int,range) = X: X must be a row vector with the\ + same number of elements as range"); + jump_to_top_level (); + } + if (columns () == 2 && is_zero_one (rj) && rhs_nc == 1) + { + do_matrix_assignment (rhs, i, 1); + } + else + { + int jmax; + index_check (rj, jmax, "column"); + maybe_resize (i, jmax); + do_matrix_assignment (rhs, i, rj); + } + } + break; + case magic_colon: + { + int nc = columns (); + if (nc == 0 && rows () == 0 && rhs_nr == 1) + { + if (rhs.is_complex_type ()) + { + complex_matrix = new ComplexMatrix (); + type_tag = complex_matrix_constant; + } + else + { + matrix = new Matrix (); + type_tag = matrix_constant; + } + maybe_resize (i, rhs_nc-1); + } + else if (indexed_assign_conforms (1, nc, rhs_nr, rhs_nc)) + maybe_resize (i, nc-1); + else + { + error ("A(int,:) = X: X must be a row vector with the\ + same number of columns as A"); + jump_to_top_level (); + } + + do_matrix_assignment (rhs, i, magic_colon); + } + break; + default: + panic_impossible (); + break; + } +} + +void +tree_constant_rep::do_matrix_assignment (tree_constant& rhs, idx_vector& iv, + tree_constant& j_arg) +{ + tree_constant tmp_j = j_arg.make_numeric_or_range_or_magic (); + + tree_constant_rep::constant_type jtype = tmp_j.const_type (); + + int rhs_nr = rhs.rows (); + int rhs_nc = rhs.columns (); + +// index_check() and matrix_to_index_vector() jump to the top level on +// errors. + + switch (jtype) + { + case complex_scalar_constant: + case scalar_constant: + { + int j = tree_to_mat_idx (tmp_j.double_value ()); + index_check (j, "column"); + if (! indexed_assign_conforms (iv.capacity (), 1, rhs_nr, rhs_nc)) + { + error ("A(matrix,int) = X: X must be a column vector with\ + the same number of elements as matrix"); + jump_to_top_level (); + } + maybe_resize (iv.max (), j); + do_matrix_assignment (rhs, iv, j); + } + break; + case complex_matrix_constant: + case matrix_constant: + { + Matrix mj = tmp_j.matrix_value (); + idx_vector jv (mj, user_pref.do_fortran_indexing, "column", + columns ()); + if (! indexed_assign_conforms (iv.capacity (), jv.capacity (), + rhs_nr, rhs_nc)) + { + error ("A(r_matrix,c_matrix) = X: the number of rows in X\ + must match the number of elements in r_matrix and the number of\ + columns in X must match the number of elements in c_matrix"); + jump_to_top_level (); + } + maybe_resize (iv.max (), jv.max ()); + do_matrix_assignment (rhs, iv, jv); + } + break; + case string_constant: + gripe_string_invalid (); + break; + case range_constant: + { + Range rj = tmp_j.range_value (); + if (! indexed_assign_conforms (iv.capacity (), rj.nelem (), + rhs_nr, rhs_nc)) + { + error ("A(matrix,range) = X: the number of rows in X must\ + match the number of elements in matrix and the number of columns in X\ + must match the number of elements in range"); + jump_to_top_level (); + } + if (columns () == 2 && is_zero_one (rj) && rhs_nc == 1) + { + do_matrix_assignment (rhs, iv, 1); + } + else + { + int jmax; + index_check (rj, jmax, "column"); + maybe_resize (iv.max (), jmax); + do_matrix_assignment (rhs, iv, rj); + } + } + break; + case magic_colon: + { + int nc = columns (); + if (! indexed_assign_conforms (iv.capacity (), nc, rhs_nr, rhs_nc)) + { + error ("A(matrix,:) = X: the number of rows in X must\ + match the number of elements in matrix, and the number of columns in\ + X must match the number of columns in A"); + jump_to_top_level (); + } + maybe_resize (iv.max (), nc-1); + do_matrix_assignment (rhs, iv, magic_colon); + } + break; + default: + panic_impossible (); + break; + } +} + +void +tree_constant_rep::do_matrix_assignment (tree_constant& rhs, + Range& ri, int imax, + tree_constant& j_arg) +{ + tree_constant tmp_j = j_arg.make_numeric_or_range_or_magic (); + + tree_constant_rep::constant_type jtype = tmp_j.const_type (); + + int rhs_nr = rhs.rows (); + int rhs_nc = rhs.columns (); + +// index_check() and matrix_to_index_vector() jump to the top level on +// errors. + + switch (jtype) + { + case complex_scalar_constant: + case scalar_constant: + { + int j = tree_to_mat_idx (tmp_j.double_value ()); + index_check (j, "column"); + if (! indexed_assign_conforms (ri.nelem (), 1, rhs_nr, rhs_nc)) + { + error ("A(range,int) = X: X must be a column vector with\ + the same number of elements as range"); + jump_to_top_level (); + jump_to_top_level (); + } + maybe_resize (imax, j); + do_matrix_assignment (rhs, ri, j); + } + break; + case complex_matrix_constant: + case matrix_constant: + { + Matrix mj = tmp_j.matrix_value (); + idx_vector jv (mj, user_pref.do_fortran_indexing, "column", + columns ()); + if (! indexed_assign_conforms (ri.nelem (), jv.capacity (), + rhs_nr, rhs_nc)) + { + error ("A(range,matrix) = X: the number of rows in X must\ + match the number of elements in range and the number of columns in X\ + must match the number of elements in matrix"); + jump_to_top_level (); + } + maybe_resize (imax, jv.max ()); + do_matrix_assignment (rhs, ri, jv); + } + break; + case string_constant: + gripe_string_invalid (); + break; + case range_constant: + { + Range rj = tmp_j.range_value (); + if (! indexed_assign_conforms (ri.nelem (), rj.nelem (), + rhs_nr, rhs_nc)) + { + error ("A(r_range,c_range) = X: the number of rows in X\ + must match the number of elements in r_range and the number of\ + columns in X must match the number of elements in c_range\n"); + jump_to_top_level (); + } + if (columns () == 2 && is_zero_one (rj) && rhs_nc == 1) + { + do_matrix_assignment (rhs, ri, 1); + } + else + { + int jmax; + index_check (rj, jmax, "column"); + maybe_resize (imax, jmax); + do_matrix_assignment (rhs, ri, rj); + } + } + break; + case magic_colon: + { + int nc = columns (); + if (! indexed_assign_conforms (ri.nelem (), nc, rhs_nr, rhs_nc)) + { + error ("A(range,:) = X: the number of rows in X must match\ + the number of elements in range, and the number of columns in X must\ + match the number of columns in A"); + jump_to_top_level (); + } + maybe_resize (imax, nc-1); + do_matrix_assignment (rhs, ri, magic_colon); + } + break; + default: + panic_impossible (); + break; + } +} + +void +tree_constant_rep::do_matrix_assignment (tree_constant& rhs, + tree_constant_rep::constant_type i, + tree_constant& j_arg) +{ + tree_constant tmp_j = j_arg.make_numeric_or_range_or_magic (); + + tree_constant_rep::constant_type jtype = tmp_j.const_type (); + + int rhs_nr = rhs.rows (); + int rhs_nc = rhs.columns (); + +// index_check() and matrix_to_index_vector() jump to the top level on +// errors. + + switch (jtype) + { + case complex_scalar_constant: + case scalar_constant: + { + int j = tree_to_mat_idx (tmp_j.double_value ()); + index_check (j, "column"); + int nr = rows (); + if (nr == 0 && columns () == 0 && rhs_nc == 1) + { + if (rhs.is_complex_type ()) + { + complex_matrix = new ComplexMatrix (); + type_tag = complex_matrix_constant; + } + else + { + matrix = new Matrix (); + type_tag = matrix_constant; + } + maybe_resize (rhs_nr-1, j); + } + else if (indexed_assign_conforms (nr, 1, rhs_nr, rhs_nc)) + maybe_resize (nr-1, j); + else + { + error ("A(:,int) = X: X must be a column vector with the\ + same number of rows as A"); + jump_to_top_level (); + } + + do_matrix_assignment (rhs, magic_colon, j); + } + break; + case complex_matrix_constant: + case matrix_constant: + { + Matrix mj = tmp_j.matrix_value (); + idx_vector jv (mj, user_pref.do_fortran_indexing, "column", + columns ()); + int nr = rows (); + if (! indexed_assign_conforms (nr, jv.capacity (), rhs_nr, rhs_nc)) + { + error ("A(:,matrix) = X: the number of rows in X must\ + match the number of rows in A, and the number of columns in X must\ + match the number of elements in matrix"); + jump_to_top_level (); + } + maybe_resize (nr-1, jv.max ()); + do_matrix_assignment (rhs, magic_colon, jv); + } + break; + case string_constant: + gripe_string_invalid (); + break; + case range_constant: + { + Range rj = tmp_j.range_value (); + int nr = rows (); + if (! indexed_assign_conforms (nr, rj.nelem (), rhs_nr, rhs_nc)) + { + error ("A(:,range) = X: the number of rows in X must match\ + the number of rows in A, and the number of columns in X must match\ + the number of elements in range"); + jump_to_top_level (); + } + if (columns () == 2 && is_zero_one (rj) && rhs_nc == 1) + { + do_matrix_assignment (rhs, magic_colon, 1); + } + else + { + int jmax; + index_check (rj, jmax, "column"); + maybe_resize (nr-1, jmax); + do_matrix_assignment (rhs, magic_colon, rj); + } + } + break; + case magic_colon: +// a(:,:) = foo is equivalent to a = foo. + do_matrix_assignment (rhs, magic_colon, magic_colon); + break; + default: + panic_impossible (); + break; + } +} + +void +tree_constant_rep::do_matrix_assignment (tree_constant& rhs, int i, int j) +{ + REP_ELEM_ASSIGN (i, j, rhs.double_value (), rhs.complex_value (), + rhs.is_real_type ()); +} + +void +tree_constant_rep::do_matrix_assignment (tree_constant& rhs, int i, + idx_vector& jv) +{ + REP_RHS_MATRIX (rhs, rhs_m, rhs_cm, rhs_nr, rhs_nc); + for (int j = 0; j < jv.capacity (); j++) + REP_ELEM_ASSIGN (i, jv.elem (j), rhs_m.elem (0, j), + rhs_cm.elem (0, j), rhs.is_real_type ()); +} + +void +tree_constant_rep::do_matrix_assignment (tree_constant& rhs, int i, Range& rj) +{ + REP_RHS_MATRIX (rhs, rhs_m, rhs_cm, rhs_nr, rhs_nc); + + double b = rj.base (); + double increment = rj.inc (); + + for (int j = 0; j < rj.nelem (); j++) + { + double tmp = b + j * increment; + int col = tree_to_mat_idx (tmp); + REP_ELEM_ASSIGN (i, col, rhs_m.elem (0, j), rhs_cm.elem (0, j), + rhs.is_real_type ()); + } +} + +void +tree_constant_rep::do_matrix_assignment (tree_constant& rhs, int i, + tree_constant_rep::constant_type mcj) +{ + assert (mcj == magic_colon); + + int nc = columns (); + + if (rhs.is_matrix_type ()) + { + REP_RHS_MATRIX (rhs, rhs_m, rhs_cm, rhs_nr, rhs_nc); + + for (int j = 0; j < nc; j++) + REP_ELEM_ASSIGN (i, j, rhs_m.elem (0, j), rhs_cm.elem (0, j), + rhs.is_real_type ()); + } + else if (rhs.const_type () == scalar_constant && nc == 1) + { + REP_ELEM_ASSIGN (i, 0, rhs.double_value (), + rhs.complex_value (), rhs.is_real_type ()); + } + else + panic_impossible (); +} + +void +tree_constant_rep::do_matrix_assignment (tree_constant& rhs, + idx_vector& iv, int j) +{ + REP_RHS_MATRIX (rhs, rhs_m, rhs_cm, rhs_nr, rhs_nc); + + for (int i = 0; i < iv.capacity (); i++) + { + int row = iv.elem (i); + REP_ELEM_ASSIGN (row, j, rhs_m.elem (i, 0), + rhs_cm.elem (i, 0), rhs.is_real_type ()); + } +} + +void +tree_constant_rep::do_matrix_assignment (tree_constant& rhs, + idx_vector& iv, idx_vector& jv) +{ + REP_RHS_MATRIX (rhs, rhs_m, rhs_cm, rhs_nr, rhs_nc); + + for (int i = 0; i < iv.capacity (); i++) + { + int row = iv.elem (i); + for (int j = 0; j < jv.capacity (); j++) + { + int col = jv.elem (j); + REP_ELEM_ASSIGN (row, col, rhs_m.elem (i, j), + rhs_cm.elem (i, j), rhs.is_real_type ()); + } + } +} + +void +tree_constant_rep::do_matrix_assignment (tree_constant& rhs, + idx_vector& iv, Range& rj) +{ + REP_RHS_MATRIX (rhs, rhs_m, rhs_cm, rhs_nr, rhs_nc); + + double b = rj.base (); + double increment = rj.inc (); + + for (int i = 0; i < iv.capacity (); i++) + { + int row = iv.elem (i); + for (int j = 0; j < rj.nelem (); j++) + { + double tmp = b + j * increment; + int col = tree_to_mat_idx (tmp); + REP_ELEM_ASSIGN (row, col, rhs_m.elem (i, j), + rhs_cm.elem (i, j), rhs.is_real_type ()); + } + } +} + +void +tree_constant_rep::do_matrix_assignment (tree_constant& rhs, idx_vector& iv, + tree_constant_rep::constant_type mcj) +{ + assert (mcj == magic_colon); + + REP_RHS_MATRIX (rhs, rhs_m, rhs_cm, rhs_nr, rhs_nc); + + int nc = columns (); + + for (int j = 0; j < nc; j++) + { + for (int i = 0; i < iv.capacity (); i++) + { + int row = iv.elem (i); + REP_ELEM_ASSIGN (row, j, rhs_m.elem (i, j), + rhs_cm.elem (i, j), rhs.is_real_type ()); + } + } +} + +void +tree_constant_rep::do_matrix_assignment (tree_constant& rhs, Range& ri, int j) +{ + REP_RHS_MATRIX (rhs, rhs_m, rhs_cm, rhs_nr, rhs_nc); + + double b = ri.base (); + double increment = ri.inc (); + + for (int i = 0; i < ri.nelem (); i++) + { + double tmp = b + i * increment; + int row = tree_to_mat_idx (tmp); + REP_ELEM_ASSIGN (row, j, rhs_m.elem (i, 0), + rhs_cm.elem (i, 0), rhs.is_real_type ()); + } +} + +void +tree_constant_rep::do_matrix_assignment (tree_constant& rhs, Range& ri, + idx_vector& jv) +{ + REP_RHS_MATRIX (rhs, rhs_m, rhs_cm, rhs_nr, rhs_nc); + + double b = ri.base (); + double increment = ri.inc (); + + for (int j = 0; j < jv.capacity (); j++) + { + int col = jv.elem (j); + for (int i = 0; i < ri.nelem (); i++) + { + double tmp = b + i * increment; + int row = tree_to_mat_idx (tmp); + REP_ELEM_ASSIGN (row, col, rhs_m.elem (i, j), + rhs_m.elem (i, j), rhs.is_real_type ()); + } + } +} + +void +tree_constant_rep::do_matrix_assignment (tree_constant& rhs, Range& ri, + Range& rj) +{ + double ib = ri.base (); + double iinc = ri.inc (); + double jb = rj.base (); + double jinc = rj.inc (); + + REP_RHS_MATRIX (rhs, rhs_m, rhs_cm, rhs_nr, rhs_nc); + + for (int i = 0; i < ri.nelem (); i++) + { + double itmp = ib + i * iinc; + int row = tree_to_mat_idx (itmp); + for (int j = 0; j < rj.nelem (); j++) + { + double jtmp = jb + j * jinc; + int col = tree_to_mat_idx (jtmp); + REP_ELEM_ASSIGN (row, col, rhs_m.elem (i, j), + rhs_cm.elem (i, j), rhs.is_real_type ()); + } + } +} + +void +tree_constant_rep::do_matrix_assignment (tree_constant& rhs, Range& ri, + tree_constant_rep::constant_type mcj) +{ + assert (mcj == magic_colon); + + REP_RHS_MATRIX (rhs, rhs_m, rhs_cm, rhs_nr, rhs_nc); + + double ib = ri.base (); + double iinc = ri.inc (); + + int nc = columns (); + + for (int i = 0; i < ri.nelem (); i++) + { + double itmp = ib + i * iinc; + int row = tree_to_mat_idx (itmp); + for (int j = 0; j < nc; j++) + REP_ELEM_ASSIGN (row, j, rhs_m.elem (i, j), + rhs_cm.elem (i, j), rhs.is_real_type ()); + } +} + +void +tree_constant_rep::do_matrix_assignment (tree_constant& rhs, + tree_constant_rep::constant_type mci, + int j) +{ + assert (mci == magic_colon); + + int nr = rows (); + + if (rhs.is_matrix_type ()) + { + REP_RHS_MATRIX (rhs, rhs_m, rhs_cm, rhs_nr, rhs_nc); + + for (int i = 0; i < nr; i++) + REP_ELEM_ASSIGN (i, j, rhs_m.elem (i, 0), + rhs_cm.elem (i, 0), rhs.is_real_type ()); + } + else if (rhs.const_type () == scalar_constant && nr == 1) + { + REP_ELEM_ASSIGN (0, j, rhs.double_value (), + rhs.complex_value (), rhs.is_real_type ()); + } + else + panic_impossible (); +} + +void +tree_constant_rep::do_matrix_assignment (tree_constant& rhs, + tree_constant_rep::constant_type mci, + idx_vector& jv) +{ + assert (mci == magic_colon); + + REP_RHS_MATRIX (rhs, rhs_m, rhs_cm, rhs_nr, rhs_nc); + + int nr = rows (); + + for (int i = 0; i < nr; i++) + { + for (int j = 0; j < jv.capacity (); j++) + { + int col = jv.elem (j); + REP_ELEM_ASSIGN (i, col, rhs_m.elem (i, j), + rhs_cm.elem (i, j), rhs.is_real_type ()); + } + } +} + +void +tree_constant_rep::do_matrix_assignment (tree_constant& rhs, + tree_constant_rep::constant_type mci, + Range& rj) +{ + assert (mci == magic_colon); + + REP_RHS_MATRIX (rhs, rhs_m, rhs_cm, rhs_nr, rhs_nc); + + int nr = rows (); + + double jb = rj.base (); + double jinc = rj.inc (); + + for (int j = 0; j < rj.nelem (); j++) + { + double jtmp = jb + j * jinc; + int col = tree_to_mat_idx (jtmp); + for (int i = 0; i < nr; i++) + { + REP_ELEM_ASSIGN (i, col, rhs_m.elem (i, j), + rhs_cm.elem (i, j), rhs.is_real_type ()); + } + } +} + +void +tree_constant_rep::do_matrix_assignment (tree_constant& rhs, + tree_constant_rep::constant_type mci, + tree_constant_rep::constant_type mcj) +{ + assert (mci == magic_colon && mcj == magic_colon); + + switch (type_tag) + { + case scalar_constant: + break; + case matrix_constant: + delete matrix; + break; + case complex_scalar_constant: + delete complex_scalar; + break; + case complex_matrix_constant: + delete complex_matrix; + break; + case string_constant: + delete [] string; + break; + case range_constant: + delete range; + break; + case magic_colon: + default: + panic_impossible (); + break; + } + + type_tag = rhs.const_type (); + + switch (type_tag) + { + case scalar_constant: + scalar = rhs.double_value (); + break; + case matrix_constant: + matrix = new Matrix (rhs.matrix_value ()); + break; + case string_constant: + string = strsave (rhs.string_value ()); + break; + case complex_matrix_constant: + complex_matrix = new ComplexMatrix (rhs.complex_matrix_value ()); + break; + case complex_scalar_constant: + complex_scalar = new Complex (rhs.complex_value ()); + break; + case range_constant: + range = new Range (rhs.range_value ()); + break; + case magic_colon: + default: + panic_impossible (); + break; + } +} + +/* +;;; Local Variables: *** +;;; mode: C++ *** +;;; page-delimiter: "^/\\*" *** +;;; End: *** +*/ +
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/tc-extras.cc Sun Aug 08 01:13:40 1993 +0000 @@ -0,0 +1,1213 @@ +// Some extra friends of the tree constant class. -*- C++ -*- +// See also the other tc-*.cc files. +/* + +Copyright (C) 1992, 1993 John W. Eaton + +This file is part of Octave. + +Octave is free software; you can redistribute it and/or modify it +under the terms of the GNU General Public License as published by the +Free Software Foundation; either version 2, or (at your option) any +later version. + +Octave is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +for more details. + +You should have received a copy of the GNU General Public License +along with Octave; see the file COPYING. If not, write to the Free +Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. + +*/ + +#ifdef __GNUG__ +#pragma implementation +#endif + +#include <strstream.h> +#include <iostream.h> +#include <fstream.h> +#include <string.h> +#include <ctype.h> + +#include "unwind-prot.h" +#include "tree-const.h" +#include "user-prefs.h" +#include "variables.h" +#include "octave.h" +#include "gripes.h" +#include "error.h" +#include "input.h" +#include "octave-hist.h" +#include "pager.h" +#include "utils.h" +#include "parse.h" +#include "lex.h" + +Matrix +max (const Matrix& a, const Matrix& b) +{ + int nr = a.rows (); + int nc = a.columns (); + if (nr != b.rows () || nc != b.columns ()) + FAIL; + + Matrix result (nr, nc); + + for (int j = 0; j < nc; j++) + for (int i = 0; i < nr; i++) + { + double a_elem = a.elem (i, j); + double b_elem = b.elem (i, j); + result.elem (i, j) = MAX (a_elem, b_elem); + } + + return result; +} + +Matrix +min (const Matrix& a, const Matrix& b) +{ + int nr = a.rows (); + int nc = a.columns (); + if (nr != b.rows () || nc != b.columns ()) + FAIL; + + Matrix result (nr, nc); + + for (int j = 0; j < nc; j++) + for (int i = 0; i < nr; i++) + { + double a_elem = a.elem (i, j); + double b_elem = b.elem (i, j); + result.elem (i, j) = MIN (a_elem, b_elem); + } + + return result; +} + +static void +get_dimensions (tree_constant& a, char *warn_for, int& nr, int& nc) +{ + tree_constant tmpa = a.make_numeric (); + + if (tmpa.is_scalar_type ()) + { + double tmp = tmpa.double_value (); + nr = nc = NINT (tmp); + } + else + { + nr = a.rows (); + nc = a.columns (); + } + + check_dimensions (nr, nc, warn_for); // No return on error. +} + +static void +get_dimensions (tree_constant& a, tree_constant& b, char *warn_for, + int& nr, int& nc) +{ + tree_constant tmpa = a.make_numeric (); + tree_constant tmpb = b.make_numeric (); + + if (tmpa.is_scalar_type () && tmpb.is_scalar_type ()) + { + nr = NINT (tmpa.double_value ()); + nc = NINT (tmpb.double_value ()); + + check_dimensions (nr, nc, warn_for); // No return on error. + } + else + { + error ("%s: expecting two scalar arguments", warn_for); + jump_to_top_level (); + } +} + +tree_constant +fill_matrix (tree_constant& a, double val, char *warn_for) +{ + int nr, nc; + get_dimensions (a, warn_for, nr, nc); // No return on error. + + Matrix m (nr, nc, val); + + return tree_constant (m); +} + +tree_constant +fill_matrix (tree_constant& a, tree_constant& b, double val, char *warn_for) +{ + int nr, nc; + get_dimensions (a, b, warn_for, nr, nc); // No return on error. + + Matrix m (nr, nc, val); + + return tree_constant (m); +} + +tree_constant +identity_matrix (tree_constant& a) +{ + int nr, nc; + get_dimensions (a, "eye", nr, nc); // No return on error. + + Matrix m (nr, nc, 0.0); + + if (nr > 0 && nc > 0) + { + int n = MIN (nr, nc); + for (int i = 0; i < n; i++) + m.elem (i, i) = 1.0; + } + + return tree_constant (m); +} + +tree_constant +identity_matrix (tree_constant& a, tree_constant& b) +{ + int nr, nc; + get_dimensions (a, b, "eye", nr, nc); // No return on error. + + Matrix m (nr, nc, 0.0); + + if (nr > 0 && nc > 0) + { + int n = MIN (nr, nc); + for (int i = 0; i < n; i++) + m.elem (i, i) = 1.0; + } + + return tree_constant (m); +} + +static tree_constant +find_nonzero_elem_idx (const Matrix& m) +{ + int count = 0; + int m_nr = m.rows (); + int m_nc = m.columns (); + + int i; + for (int j = 0; j < m_nc; j++) + for (i = 0; i < m_nr; i++) + if (m.elem (i, j) != 0) + count++; + + Matrix result; + + if (count == 0) + return result; + + if (m_nr == 1) + { + result.resize (1, count); + count = 0; + for (j = 0; j < m_nc; j++) + if (m.elem (0, j) != 0) + { + result (0, count) = j + 1; + count++; + } + return tree_constant (result); + } + else + { + ColumnVector v (count); + count = 0; + for (j = 0; j < m_nc; j++) + for (i = 0; i < m_nr; i++) + if (m.elem (i, j) != 0) + { + v.elem (count) = m_nr * j + i + 1; + count++; + } + return tree_constant (v, 1); // Always make a column vector. + } +} + +static tree_constant +find_nonzero_elem_idx (const ComplexMatrix& m) +{ + int count = 0; + int m_nr = m.rows (); + int m_nc = m.columns (); + + for (int j = 0; j < m_nc; j++) + { + for (int i = 0; i < m_nr; i++) + if (m.elem (i, j) != 0) + count++; + } + + Matrix result; + + if (count == 0) + return result; + + if (m_nr == 1) + { + result.resize (1, count); + count = 0; + for (j = 0; j < m_nc; j++) + if (m.elem (0, j) != 0) + { + result (0, count) = j + 1; + count++; + } + return tree_constant (result); + } + else + { + ColumnVector v (count); + count = 0; + for (j = 0; j < m_nc; j++) + { + for (int i = 0; i < m_nr; i++) + if (m.elem (i, j) != 0) + { + v.elem (count) = m_nr * j + i + 1; + count++; + } + } + return tree_constant (v, 1); // Always make a column vector. + } +} + +tree_constant +find_nonzero_elem_idx (tree_constant& a) +{ + tree_constant retval; + + tree_constant tmp = a.make_numeric (); + + Matrix result; + + switch (tmp.const_type ()) + { + case tree_constant_rep::matrix_constant: + { + Matrix m = tmp.matrix_value (); + return find_nonzero_elem_idx (m); + } + break; + case tree_constant_rep::scalar_constant: + { + double d = tmp.double_value (); + if (d != 0.0) + return tree_constant (1.0); + else + return tree_constant (result); + } + break; + case tree_constant_rep::complex_matrix_constant: + { + ComplexMatrix m = tmp.complex_matrix_value (); + return find_nonzero_elem_idx (m); + } + break; + case tree_constant_rep::complex_scalar_constant: + { + Complex c = tmp.complex_value (); + if (c != 0.0) + return tree_constant (1.0); + else + return tree_constant (result); + } + break; + default: + break; + } + return retval; +} + +// XXX FIXME XXX -- the next three functions should really be just +// one... + +tree_constant * +matrix_exp (tree_constant& a) +{ + tree_constant *retval = new tree_constant [2]; + + tree_constant tmp = a.make_numeric ();; + + if (tmp.rows () == 0 || tmp.columns () == 0) + { + int flag = user_pref.propagate_empty_matrices; + if (flag != 0) + { + if (flag < 0) + gripe_empty_arg ("expm", 0); + Matrix m; + retval = new tree_constant [2]; + retval[0] = tree_constant (m); + return retval; + } + else + gripe_empty_arg ("expm", 1); + } + + switch (tmp.const_type ()) + { + case tree_constant_rep::matrix_constant: + { + Matrix m = tmp.matrix_value (); + + int nr = m.rows (); + int nc = m.columns (); + + if (nr == 0 || nc == 0 || nr != nc) + gripe_square_matrix_required ("expm"); + else + { + EIG m_eig (m); + ComplexColumnVector lambda (m_eig.eigenvalues ()); + ComplexMatrix Q (m_eig.eigenvectors ()); + + for (int i = 0; i < nr; i++) + { + Complex elt = lambda.elem (i); + if (imag (elt) == 0.0) + lambda.elem (i) = exp (real (elt)); + else + lambda.elem (i) = exp (elt); + } + + ComplexDiagMatrix D (lambda); + ComplexMatrix result = Q * D * Q.inverse (); + + retval[0] = tree_constant (result); + } + } + break; + case tree_constant_rep::complex_matrix_constant: + { + ComplexMatrix m = tmp.complex_matrix_value (); + + int nr = m.rows (); + int nc = m.columns (); + + if (nr == 0 || nc == 0 || nr != nc) + gripe_square_matrix_required ("expm"); + else + { + EIG m_eig (m); + ComplexColumnVector lambda (m_eig.eigenvalues ()); + ComplexMatrix Q (m_eig.eigenvectors ()); + + for (int i = 0; i < nr; i++) + { + Complex elt = lambda.elem (i); + if (imag (elt) == 0.0) + lambda.elem (i) = exp (real (elt)); + else + lambda.elem (i) = exp (elt); + } + + ComplexDiagMatrix D (lambda); + ComplexMatrix result = Q * D * Q.inverse (); + + retval[0] = tree_constant (result); + } + } + break; + case tree_constant_rep::scalar_constant: + { + double d = tmp.double_value (); + retval[0] = tree_constant (exp (d)); + } + break; + case tree_constant_rep::complex_scalar_constant: + { + Complex c = tmp.complex_value (); + retval[0] = tree_constant (exp (c)); + } + break; + default: + break; + } + return retval; +} + +tree_constant * +matrix_log (tree_constant& a) +{ + tree_constant *retval = new tree_constant [2]; + + tree_constant tmp = a.make_numeric ();; + + if (tmp.rows () == 0 || tmp.columns () == 0) + { + int flag = user_pref.propagate_empty_matrices; + if (flag != 0) + { + if (flag < 0) + gripe_empty_arg ("logm", 0); + Matrix m; + retval = new tree_constant [2]; + retval[0] = tree_constant (m); + return retval; + } + else + gripe_empty_arg ("logm", 1); + } + + switch (tmp.const_type ()) + { + case tree_constant_rep::matrix_constant: + { + Matrix m = tmp.matrix_value (); + + int nr = m.rows (); + int nc = m.columns (); + + if (nr == 0 || nc == 0 || nr != nc) + gripe_square_matrix_required ("logm"); + else + { + EIG m_eig (m); + ComplexColumnVector lambda (m_eig.eigenvalues ()); + ComplexMatrix Q (m_eig.eigenvectors ()); + + for (int i = 0; i < nr; i++) + { + Complex elt = lambda.elem (i); + if (imag (elt) == 0.0 && real (elt) > 0.0) + lambda.elem (i) = log (real (elt)); + else + lambda.elem (i) = log (elt); + } + + ComplexDiagMatrix D (lambda); + ComplexMatrix result = Q * D * Q.inverse (); + + retval[0] = tree_constant (result); + } + } + break; + case tree_constant_rep::complex_matrix_constant: + { + ComplexMatrix m = tmp.complex_matrix_value (); + + int nr = m.rows (); + int nc = m.columns (); + + if (nr == 0 || nc == 0 || nr != nc) + gripe_square_matrix_required ("logm"); + else + { + EIG m_eig (m); + ComplexColumnVector lambda (m_eig.eigenvalues ()); + ComplexMatrix Q (m_eig.eigenvectors ()); + + for (int i = 0; i < nr; i++) + { + Complex elt = lambda.elem (i); + if (imag (elt) == 0.0 && real (elt) > 0.0) + lambda.elem (i) = log (real (elt)); + else + lambda.elem (i) = log (elt); + } + + ComplexDiagMatrix D (lambda); + ComplexMatrix result = Q * D * Q.inverse (); + + retval[0] = tree_constant (result); + } + } + break; + case tree_constant_rep::scalar_constant: + { + double d = tmp.double_value (); + if (d > 0.0) + retval[0] = tree_constant (log (d)); + else + { + Complex dtmp (d); + retval[0] = tree_constant (log (dtmp)); + } + } + break; + case tree_constant_rep::complex_scalar_constant: + { + Complex c = tmp.complex_value (); + retval[0] = tree_constant (log (c)); + } + break; + default: + break; + } + return retval; +} + +tree_constant * +matrix_sqrt (tree_constant& a) +{ + tree_constant *retval = new tree_constant [2]; + + tree_constant tmp = a.make_numeric ();; + + if (tmp.rows () == 0 || tmp.columns () == 0) + { + int flag = user_pref.propagate_empty_matrices; + if (flag != 0) + { + if (flag < 0) + gripe_empty_arg ("sqrtm", 0); + Matrix m; + retval = new tree_constant [2]; + retval[0] = tree_constant (m); + return retval; + } + else + gripe_empty_arg ("sqrtm", 1); + } + + switch (tmp.const_type ()) + { + case tree_constant_rep::matrix_constant: + { + Matrix m = tmp.matrix_value (); + + int nr = m.rows (); + int nc = m.columns (); + + if (nr == 0 || nc == 0 || nr != nc) + gripe_square_matrix_required ("sqrtm"); + else + { + EIG m_eig (m); + ComplexColumnVector lambda (m_eig.eigenvalues ()); + ComplexMatrix Q (m_eig.eigenvectors ()); + + for (int i = 0; i < nr; i++) + { + Complex elt = lambda.elem (i); + if (imag (elt) == 0.0 && real (elt) > 0.0) + lambda.elem (i) = sqrt (real (elt)); + else + lambda.elem (i) = sqrt (elt); + } + + ComplexDiagMatrix D (lambda); + ComplexMatrix result = Q * D * Q.inverse (); + + retval[0] = tree_constant (result); + } + } + break; + case tree_constant_rep::complex_matrix_constant: + { + ComplexMatrix m = tmp.complex_matrix_value (); + + int nr = m.rows (); + int nc = m.columns (); + + if (nr == 0 || nc == 0 || nr != nc) + gripe_square_matrix_required ("sqrtm"); + else + { + EIG m_eig (m); + ComplexColumnVector lambda (m_eig.eigenvalues ()); + ComplexMatrix Q (m_eig.eigenvectors ()); + + for (int i = 0; i < nr; i++) + { + Complex elt = lambda.elem (i); + if (imag (elt) == 0.0 && real (elt) > 0.0) + lambda.elem (i) = sqrt (real (elt)); + else + lambda.elem (i) = sqrt (elt); + } + + ComplexDiagMatrix D (lambda); + ComplexMatrix result = Q * D * Q.inverse (); + + retval[0] = tree_constant (result); + } + } + break; + case tree_constant_rep::scalar_constant: + { + double d = tmp.double_value (); + if (d > 0.0) + retval[0] = tree_constant (sqrt (d)); + else + { + Complex dtmp (d); + retval[0] = tree_constant (sqrt (dtmp)); + } + } + break; + case tree_constant_rep::complex_scalar_constant: + { + Complex c = tmp.complex_value (); + retval[0] = tree_constant (log (c)); + } + break; + default: + break; + } + return retval; +} + +tree_constant * +column_max (tree_constant *args, int nargin, int nargout) +{ + tree_constant *retval = NULL_TREE_CONST; + + tree_constant arg1; + tree_constant arg2; + tree_constant_rep::constant_type arg1_type = + tree_constant_rep::unknown_constant; + tree_constant_rep::constant_type arg2_type = + tree_constant_rep::unknown_constant; + + switch (nargin) + { + case 3: + arg2 = args[2].make_numeric (); + arg2_type = arg2.const_type (); +// Fall through... + case 2: + arg1 = args[1].make_numeric (); + arg1_type = arg1.const_type (); + break; + default: + panic_impossible (); + break; + } + + if (nargin == 2 && nargout == 1) + { + retval = new tree_constant [2]; + if (arg1_type == tree_constant_rep::scalar_constant) + retval[0] = tree_constant (arg1.double_value ()); + else + { + Matrix m = arg1.matrix_value (); + if (m.rows () == 1) + retval[0] = tree_constant (m.row_max ()); + else + retval[0] = tree_constant (m.column_max (), 0); + } + } + else if (nargin == 2 && nargout == 2) + message ((char *) NULL, "[X, I] = max (A): Not implemented"); + else if (nargin == 3) + { + if (arg1.rows () == arg2.rows () + && arg1.columns () == arg2.columns ()) + { + retval = new tree_constant [2]; + if (arg1_type == tree_constant_rep::scalar_constant) + { + double result; + double a_elem = arg1.double_value (); + double b_elem = arg2.double_value (); + result = MAX (a_elem, b_elem); + retval[0] = tree_constant (result); + } + else + { + Matrix result; + result = max (arg1.matrix_value (), arg2.matrix_value ()); + retval[0] = tree_constant (result); + } + } + else + message ("max", "nonconformant matrices"); + } + else + panic_impossible (); + + return retval; +} + +tree_constant * +column_min (tree_constant *args, int nargin, int nargout) +{ + tree_constant *retval = NULL_TREE_CONST; + + tree_constant arg1; + tree_constant arg2; + tree_constant_rep::constant_type arg1_type = + tree_constant_rep::unknown_constant; + tree_constant_rep::constant_type arg2_type = + tree_constant_rep::unknown_constant; + + switch (nargin) + { + case 3: + arg2 = args[2].make_numeric (); + arg2_type = arg2.const_type (); +// Fall through... + case 2: + arg1 = args[1].make_numeric (); + arg1_type = arg1.const_type (); + break; + default: + panic_impossible (); + break; + } + + if (nargin == 2 && nargout == 1) + { + retval = new tree_constant [2]; + if (arg1_type == tree_constant_rep::scalar_constant) + retval[0] = tree_constant (arg1.double_value ()); + else + { + Matrix m = arg1.matrix_value (); + if (m.rows () == 1) + retval[0] = tree_constant (m.row_min ()); + else + retval[0] = tree_constant (m.column_min (), 0); + } + } + else if (nargin == 2 && nargout == 2) + message ((char *) NULL, "[X, I] = min (A): Not implemented"); + else if (nargin == 3) + { + if (arg1.rows () == arg2.rows () + && arg1.columns () == arg2.columns ()) + { + retval = new tree_constant [2]; + if (arg1_type == tree_constant_rep::scalar_constant) + { + double result; + double a_elem = arg1.double_value (); + double b_elem = arg2.double_value (); + result = MIN (a_elem, b_elem); + retval[0] = tree_constant (result); + } + else + { + Matrix result; + result = min (arg1.matrix_value (), arg2.matrix_value ()); + retval[0] = tree_constant (result); + } + } + else + message ("min", "nonconformant matrices"); + } + else + panic_impossible (); + + return retval; +} + +static void +mx_sort (Matrix& m, Matrix& idx, int return_idx) +{ + int nr = m.rows (); + int nc = m.columns (); + idx.resize (nr, nc); + int i, j; + + if (return_idx) + { + for (j = 0; j < nc; j++) + for (i = 0; i < nr; i++) + idx.elem (i, j) = i+1; + } + + for (j = 0; j < nc; j++) + { + for (int gap = nr/2; gap > 0; gap /= 2) + for (i = gap; i < nr; i++) + for (int k = i - gap; + k >= 0 && m.elem (k, j) > m.elem (k+gap, j); + k -= gap) + { + double tmp = m.elem (k, j); + m.elem (k, j) = m.elem (k+gap, j); + m.elem (k+gap, j) = tmp; + + if (return_idx) + { + double tmp = idx.elem (k, j); + idx.elem (k, j) = idx.elem (k+gap, j); + idx.elem (k+gap, j) = tmp; + } + } + } +} + +static void +mx_sort (RowVector& v, RowVector& idx, int return_idx) +{ + int n = v.capacity (); + idx.resize (n); + int i; + + if (return_idx) + for (i = 0; i < n; i++) + idx.elem (i) = i+1; + + for (int gap = n/2; gap > 0; gap /= 2) + for (i = gap; i < n; i++) + for (int k = i - gap; + k >= 0 && v.elem (k) > v.elem (k+gap); + k -= gap) + { + double tmp = v.elem (k); + v.elem (k) = v.elem (k+gap); + v.elem (k+gap) = tmp; + + if (return_idx) + { + double tmp = idx.elem (k); + idx.elem (k) = idx.elem (k+gap); + idx.elem (k+gap) = tmp; + } + } +} + +static void +mx_sort (ComplexMatrix& cm, Matrix& idx, int return_idx) +{ + int nr = cm.rows (); + int nc = cm.columns (); + idx.resize (nr, nc); + int i, j; + + if (return_idx) + { + for (j = 0; j < nc; j++) + for (i = 0; i < nr; i++) + idx.elem (i, j) = i+1; + } + + for (j = 0; j < nc; j++) + { + for (int gap = nr/2; gap > 0; gap /= 2) + for (i = gap; i < nr; i++) + for (int k = i - gap; + k >= 0 && abs (cm.elem (k, j)) > abs (cm.elem (k+gap, j)); + k -= gap) + { + Complex ctmp = cm.elem (k, j); + cm.elem (k, j) = cm.elem (k+gap, j); + cm.elem (k+gap, j) = ctmp; + + if (return_idx) + { + double tmp = idx.elem (k, j); + idx.elem (k, j) = idx.elem (k+gap, j); + idx.elem (k+gap, j) = tmp; + } + } + } +} + +static void +mx_sort (ComplexRowVector& cv, RowVector& idx, int return_idx) +{ + int n = cv.capacity (); + idx.resize (n); + int i; + + if (return_idx) + for (i = 0; i < n; i++) + idx.elem (i) = i+1; + + for (int gap = n/2; gap > 0; gap /= 2) + for (i = gap; i < n; i++) + for (int k = i - gap; + k >= 0 && abs (cv.elem (k)) > abs (cv.elem (k+gap)); + k -= gap) + { + Complex tmp = cv.elem (k); + cv.elem (k) = cv.elem (k+gap); + cv.elem (k+gap) = tmp; + + if (return_idx) + { + double tmp = idx.elem (k); + idx.elem (k) = idx.elem (k+gap); + idx.elem (k+gap) = tmp; + } + } +} + +tree_constant * +sort (tree_constant *args, int nargin, int nargout) +{ +// Assumes that we have been given the correct number of arguments. + + tree_constant *retval = NULL_TREE_CONST; + + int return_idx = nargout > 1; + if (return_idx) + retval = new tree_constant [3]; + else + retval = new tree_constant [2]; + + switch (args[1].const_type ()) + { + case tree_constant_rep::scalar_constant: + { + retval [0] = tree_constant (args[1].double_value ()); + if (return_idx) + retval [1] = tree_constant (1.0); + } + break; + case tree_constant_rep::complex_scalar_constant: + { + retval [0] = tree_constant (args[1].complex_value ()); + if (return_idx) + retval [1] = tree_constant (1.0); + } + break; + case tree_constant_rep::string_constant: + case tree_constant_rep::range_constant: + case tree_constant_rep::matrix_constant: + { + Matrix m = args[1].to_matrix (); + if (m.rows () == 1) + { + int nc = m.columns (); + RowVector v (nc); + for (int i = 0; i < nc; i++) + v.elem (i) = m.elem (0, i); + RowVector idx; + mx_sort (v, idx, return_idx); + + retval [0] = tree_constant (v, 0); + if (return_idx) + retval [1] = tree_constant (idx, 0); + } + else + { +// Sorts m in place, optionally computes index Matrix. + Matrix idx; + mx_sort (m, idx, return_idx); + + retval [0] = tree_constant (m); + if (return_idx) + retval [1] = tree_constant (idx); + } + } + break; + case tree_constant_rep::complex_matrix_constant: + { + ComplexMatrix cm = args[1].complex_matrix_value (); + if (cm.rows () == 1) + { + int nc = cm.columns (); + ComplexRowVector cv (nc); + for (int i = 0; i < nc; i++) + cv.elem (i) = cm.elem (0, i); + RowVector idx; + mx_sort (cv, idx, return_idx); + + retval [0] = tree_constant (cv, 0); + if (return_idx) + retval [1] = tree_constant (idx, 0); + } + else + { +// Sorts cm in place, optionally computes index Matrix. + Matrix idx; + mx_sort (cm, idx, return_idx); + + retval [0] = tree_constant (cm); + if (return_idx) + retval [1] = tree_constant (idx); + } + } + break; + default: + panic_impossible (); + break; + } + + return retval; +} + +tree_constant * +feval (tree_constant *args, int nargin, int nargout) +{ +// Assumes that we have been given the correct number of arguments. + + tree_constant *retval = NULL_TREE_CONST; + + tree *fcn = is_valid_function (args[1], "feval", 1); + if (fcn != NULL_TREE) + { + args++; + nargin--; + if (nargin > 1) + retval = fcn->eval (args, nargin, nargout, 0); + else + retval = fcn->eval (0, nargout); + } + + return retval; +} + +tree_constant +eval_string (char *string, int print, int ans_assign, + int& parse_status) +{ + begin_unwind_frame ("eval_string"); + + unwind_protect_int (get_input_from_eval_string); + unwind_protect_ptr (global_command); + unwind_protect_ptr (current_eval_string); + + get_input_from_eval_string = 1; + current_eval_string = string; + + YY_BUFFER_STATE old_buf = current_buffer (); + YY_BUFFER_STATE new_buf = create_buffer ((FILE *) NULL); + + add_unwind_protect (restore_input_buffer, (void *) old_buf); + add_unwind_protect (delete_input_buffer, (void *) new_buf); + + switch_to_buffer (new_buf); + + unwind_protect_ptr (curr_sym_tab); + symbol_table *prev_sym_tab = curr_sym_tab; + + parse_status = yyparse (); + + curr_sym_tab = prev_sym_tab; + +// Important to reset the idea of where input is coming from before +// trying to eval the command we just parsed -- it might contain the +// name of an m-file that still needs to be parsed! + + tree *command = global_command; + + run_unwind_frame ("eval_string"); + + tree_constant retval; + + if (parse_status == 0 && command != NULL_TREE) + { + retval = command->eval (print); + delete command; + } + + return retval; +} + +tree_constant +eval_string (tree_constant& arg, int& parse_status) +{ + if (! arg.is_string_type ()) + { + error ("eval: expecting string argument"); + return -1; + } + + char *string = arg.string_value (); + +// Yes Virginia, we always print here... + + return eval_string (string, 1, 1, parse_status); +} + +static int +match_sans_spaces (char *standard, char *test) +{ + char *tp = test; + while (*tp == ' ' || *tp == '\t') + tp++; + + char *ep = test + strlen (test) - 1; + while (*ep == ' ' || *ep == '\t') + ep--; + + int len = ep - tp + 1; + + return (strncmp (standard, tp, len) == 0); +} + +tree_constant +get_user_input (tree_constant *args, int nargin, int nargout, int debug = 0) +{ + tree_constant retval; + + int read_as_string = 0; + if (nargin == 3) + { + if (args[2].is_string_type () + && strcmp ("s", args[2].string_value ()) == 0) + read_as_string++; + else + { + error ("input: unrecognized second argument"); + return retval; + } + } + + char *prompt = "debug> "; + if (nargin > 1) + { + if (args[1].is_string_type ()) + prompt = args[1].string_value (); + else + { + error ("input: unrecognized argument"); + return retval; + } + } + + again: + + flush_output_to_pager (); + + char *input_buf = gnu_readline (prompt); + + if (input_buf != (char *) NULL) + { + if (input_buf) + maybe_save_history (input_buf); + + int len = strlen (input_buf); + + if (len < 1) + { + if (debug) + goto again; + else + return retval; + } + + if (match_sans_spaces ("exit", input_buf) + || match_sans_spaces ("quit", input_buf) + || match_sans_spaces ("return", input_buf)) + return tree_constant (); + else if (read_as_string) + retval = tree_constant (input_buf); + else + { + int parse_status; + retval = eval_string (input_buf, 0, 0, parse_status); + if (debug && retval.is_defined ()) + retval.eval (1); + } + } + else + error ("input: reading user-input failed!"); + + if (debug) + goto again; + + return retval; +} + +/* +;;; Local Variables: *** +;;; mode: C++ *** +;;; page-delimiter: "^/\\*" *** +;;; End: *** +*/
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/tc-index.cc Sun Aug 08 01:13:40 1993 +0000 @@ -0,0 +1,1173 @@ +// tc-index.cc -*- C++ -*- +/* + +Copyright (C) 1992, 1993 John W. Eaton + +This file is part of Octave. + +Octave is free software; you can redistribute it and/or modify it +under the terms of the GNU General Public License as published by the +Free Software Foundation; either version 2, or (at your option) any +later version. + +Octave is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +for more details. + +You should have received a copy of the GNU General Public License +along with Octave; see the file COPYING. If not, write to the Free +Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. + +*/ + +#ifdef __GNUG__ +#pragma implementation +#endif + +#include "user-prefs.h" +#include "error.h" +#include "gripes.h" +#include "utils.h" +#include "tree-const.h" + +#include "tc-inlines.cc" + +int +tree_constant_rep::valid_as_scalar_index (void) +{ + int valid = type_tag == magic_colon + || (type_tag == scalar_constant && NINT (scalar) == 1) + || (type_tag == range_constant + && range->nelem () == 1 && NINT (range->base ()) == 1); + + return valid; +} + +tree_constant +tree_constant_rep::do_scalar_index (tree_constant *args, int nargs) +{ + tree_constant retval; + + if (valid_scalar_indices (args, nargs)) + { + if (type_tag == scalar_constant) + return tree_constant (scalar); + else if (type_tag == complex_scalar_constant) + return tree_constant (*complex_scalar); + else + panic_impossible (); + } + else if (nargs != 2) + { + error ("illegal number of arguments for scalar type"); + jump_to_top_level (); + } + else if (args[1].is_matrix_type ()) + { + Matrix mi = args[1].matrix_value (); + + idx_vector i (mi, user_pref.do_fortran_indexing, ""); + + int len = i.length (); + if (len == i.ones_count ()) + { + if (type_tag == scalar_constant) + { + if (user_pref.prefer_column_vectors) + { + Matrix m (len, 1, scalar); + return tree_constant (m); + } + else + { + Matrix m (1, len, scalar); + return tree_constant (m); + } + } + else if (type_tag == complex_scalar_constant) + { + if (user_pref.prefer_column_vectors) + { + ComplexMatrix m (len, 1, *complex_scalar); + return tree_constant (m); + } + else + { + ComplexMatrix m (1, len, *complex_scalar); + return tree_constant (m); + } + } + else + panic_impossible (); + } + } + + error ("index invalid or out of range for scalar type"); + jump_to_top_level (); + + return retval; +} + +tree_constant +tree_constant_rep::do_matrix_index (tree_constant *args, int nargin) +{ + tree_constant retval; + + switch (nargin) + { + case 2: + if (args == NULL_TREE_CONST) + error ("matrix index is null"); + else if (args[1].is_undefined ()) + error ("matrix index is a null expression"); + else + retval = do_matrix_index (args[1]); + break; + case 3: + if (args == NULL_TREE_CONST) + error ("matrix indices are null"); + else if (args[1].is_undefined ()) + error ("first matrix index is a null expression"); + else if (args[2].is_undefined ()) + error ("second matrix index is a null expression"); + else + retval = do_matrix_index (args[1], args[2]); + break; + default: + error ("too many indices for matrix expression"); + break; + } + + return retval; +} + +tree_constant +tree_constant_rep::do_matrix_index (tree_constant& i_arg) +{ + tree_constant retval; + + int nr = rows (); + int nc = columns (); + + if (user_pref.do_fortran_indexing) + retval = fortran_style_matrix_index (i_arg); + else if (nr <= 1 || nc <= 1) + retval = do_vector_index (i_arg); + else + error ("single index only valid for row or column vector"); + + return retval; +} + +tree_constant +tree_constant_rep::fortran_style_matrix_index (tree_constant& i_arg) +{ + tree_constant retval; + + tree_constant tmp_i = i_arg.make_numeric_or_magic (); + + tree_constant_rep::constant_type itype = tmp_i.const_type (); + + int nr = rows (); + int nc = columns (); + + switch (itype) + { + case complex_scalar_constant: + case scalar_constant: + { + int i = NINT (tmp_i.double_value ()); + int ii = fortran_row (i, nr) - 1; + int jj = fortran_column (i, nr) - 1; + index_check (i-1, ""); + range_max_check (i-1, nr * nc); + retval = do_matrix_index (ii, jj); + } + break; + case complex_matrix_constant: + case matrix_constant: + { + Matrix mi = tmp_i.matrix_value (); + if (mi.rows () == 0 || mi.columns () == 0) + { + Matrix mtmp; + retval = tree_constant (mtmp); + } + else + { +// Yes, we really do want to call this with mi. + retval = fortran_style_matrix_index (mi); + } + } + break; + case string_constant: + gripe_string_invalid (); + jump_to_top_level (); + break; + case range_constant: + gripe_range_invalid (); + jump_to_top_level (); + break; + case magic_colon: + retval = do_matrix_index (magic_colon); + break; + default: + panic_impossible (); + break; + } + + return retval; +} + +tree_constant +tree_constant_rep::fortran_style_matrix_index (Matrix& mi) +{ + assert (is_matrix_type ()); + + tree_constant retval; + + int nr = rows (); + int nc = columns (); + + int len = nr * nc; + + int index_nr = mi.rows (); + int index_nc = mi.columns (); + + if (index_nr >= 1 && index_nc >= 1) + { + double *cop_out = (double *) NULL; + Complex *c_cop_out = (Complex *) NULL; + int real_type = type_tag == matrix_constant; + if (real_type) + cop_out = matrix->fortran_vec (); + else + c_cop_out = complex_matrix->fortran_vec (); + + double *cop_out_index = mi.fortran_vec (); + + idx_vector iv (mi, 1, "", len); + + int result_size = iv.length (); + + if (columns () == 1 || iv.one_zero_only ()) + { + CRMATRIX (m, cm, result_size, 1); + + for (int i = 0; i < result_size; i++) + { + int idx = iv.elem (i); + CRMATRIX_ASSIGN_ELEM (m, cm, i, 0, cop_out [idx], + c_cop_out [idx], real_type); + } + + ASSIGN_CRMATRIX_TO (retval, m, cm); + } + else if (rows () == 1) + { + CRMATRIX (m, cm, 1, result_size); + + for (int i = 0; i < result_size; i++) + { + int idx = iv.elem (i); + CRMATRIX_ASSIGN_ELEM (m, cm, 0, i, cop_out [idx], + c_cop_out [idx], real_type); + } + + ASSIGN_CRMATRIX_TO (retval, m, cm); + } + else + { + CRMATRIX (m, cm, index_nr, index_nc); + + for (int j = 0; j < index_nc; j++) + for (int i = 0; i < index_nr; i++) + { + double tmp = *cop_out_index++; + int idx = tree_to_mat_idx (tmp); + CRMATRIX_ASSIGN_ELEM (m, cm, i, j, cop_out [idx], + c_cop_out [idx], real_type); + } + + ASSIGN_CRMATRIX_TO (retval, m, cm); + } + } + else + { + if (index_nr == 0 || index_nc == 0) + error ("empty matrix invalid as index"); + else + error ("invalid matrix index"); + jump_to_top_level (); + } + + return retval; +} + +tree_constant +tree_constant_rep::do_vector_index (tree_constant& i_arg) +{ + tree_constant retval; + + tree_constant tmp_i = i_arg.make_numeric_or_range_or_magic (); + + tree_constant_rep::constant_type itype = tmp_i.const_type (); + + int nr = rows (); + int nc = columns (); + + int len = nr > nc ? nr : nc; + + assert ((nr == 1 || nc == 1) && ! user_pref.do_fortran_indexing); + + int swap_indices = (nr == 1); + + switch (itype) + { + case complex_scalar_constant: + case scalar_constant: + { + int i = tree_to_mat_idx (tmp_i.double_value ()); + index_check (i, ""); + if (swap_indices) + { + range_max_check (i, nc); + retval = do_matrix_index (0, i); + } + else + { + range_max_check (i, nr); + retval = do_matrix_index (i, 0); + } + } + break; + case complex_matrix_constant: + case matrix_constant: + { + Matrix mi = tmp_i.matrix_value (); + if (mi.rows () == 0 || mi.columns () == 0) + { + Matrix mtmp; + retval = tree_constant (mtmp); + } + else + { + idx_vector iv (mi, user_pref.do_fortran_indexing, "", len); + int imax = iv.max (); + if (swap_indices) + { + range_max_check (imax, nc); + retval = do_matrix_index (0, iv); + } + else + { + range_max_check (imax, nr); + retval = do_matrix_index (iv, 0); + } + } + } + break; + case string_constant: + gripe_string_invalid (); + break; + case range_constant: + { + Range ri = tmp_i.range_value (); + if (len == 2 && is_zero_one (ri)) + { + if (swap_indices) + retval = do_matrix_index (0, 1); + else + retval = do_matrix_index (1, 0); + } + else + { + int imax; + index_check (ri, imax, ""); + if (swap_indices) + { + range_max_check (imax, nc); + retval = do_matrix_index (0, ri); + } + else + { + range_max_check (imax, nr); + retval = do_matrix_index (ri, 0); + } + } + } + break; + case magic_colon: + if (swap_indices) + retval = do_matrix_index (0, magic_colon); + else + retval = do_matrix_index (magic_colon, 0); + break; + default: + panic_impossible (); + break; + } + + return retval; +} + +tree_constant +tree_constant_rep::do_matrix_index (tree_constant& i_arg, tree_constant& j_arg) +{ + tree_constant retval; + + tree_constant tmp_i = i_arg.make_numeric_or_range_or_magic (); + + tree_constant_rep::constant_type itype = tmp_i.const_type (); + + switch (itype) + { + case complex_scalar_constant: + case scalar_constant: + { + int i = tree_to_mat_idx (tmp_i.double_value ()); + index_check (i, "row"); + retval = do_matrix_index (i, j_arg); + } + break; + case complex_matrix_constant: + case matrix_constant: + { + Matrix mi = tmp_i.matrix_value (); + idx_vector iv (mi, user_pref.do_fortran_indexing, "row", rows ()); + if (iv.length () == 0) + { + Matrix mtmp; + retval = tree_constant (mtmp); + } + else + retval = do_matrix_index (iv, j_arg); + } + break; + case string_constant: + gripe_string_invalid (); + break; + case range_constant: + { + Range ri = tmp_i.range_value (); + if (rows () == 2 && is_zero_one (ri)) + { + retval = do_matrix_index (1, j_arg); + } + else + { + int imax; + index_check (ri, imax, "row"); + retval = do_matrix_index (ri, imax, j_arg); + } + } + break; + case magic_colon: + retval = do_matrix_index (magic_colon, j_arg); + break; + default: + panic_impossible (); + break; + } + + return retval; +} + +tree_constant +tree_constant_rep::do_matrix_index (int i, tree_constant& j_arg) +{ + tree_constant retval; + + tree_constant tmp_j = j_arg.make_numeric_or_range_or_magic (); + + tree_constant_rep::constant_type jtype = tmp_j.const_type (); + + int nr = rows (); + int nc = columns (); + + switch (jtype) + { + case complex_scalar_constant: + case scalar_constant: + { + int j = tree_to_mat_idx (tmp_j.double_value ()); + index_check (j, "column"); + range_max_check (i, j, nr, nc); + retval = do_matrix_index (i, j); + } + break; + case complex_matrix_constant: + case matrix_constant: + { + Matrix mj = tmp_j.matrix_value (); + idx_vector jv (mj, user_pref.do_fortran_indexing, "column", nc); + if (jv.length () == 0) + { + Matrix mtmp; + retval = tree_constant (mtmp); + } + else + { + range_max_check (i, jv.max (), nr, nc); + retval = do_matrix_index (i, jv); + } + } + break; + case string_constant: + gripe_string_invalid (); + break; + case range_constant: + { + Range rj = tmp_j.range_value (); + if (nc == 2 && is_zero_one (rj)) + { + retval = do_matrix_index (i, 1); + } + else + { + int jmax; + index_check (rj, jmax, "column"); + range_max_check (i, jmax, nr, nc); + retval = do_matrix_index (i, rj); + } + } + break; + case magic_colon: + range_max_check (i, 0, nr, nc); + retval = do_matrix_index (i, magic_colon); + break; + default: + panic_impossible (); + break; + } + + return retval; +} + +tree_constant +tree_constant_rep::do_matrix_index (idx_vector& iv, tree_constant& j_arg) +{ + tree_constant retval; + + tree_constant tmp_j = j_arg.make_numeric_or_range_or_magic (); + + tree_constant_rep::constant_type jtype = tmp_j.const_type (); + + int nr = rows (); + int nc = columns (); + + switch (jtype) + { + case complex_scalar_constant: + case scalar_constant: + { + int j = tree_to_mat_idx (tmp_j.double_value ()); + index_check (j, "column"); + range_max_check (iv.max (), j, nr, nc); + retval = do_matrix_index (iv, j); + } + break; + case complex_matrix_constant: + case matrix_constant: + { + Matrix mj = tmp_j.matrix_value (); + idx_vector jv (mj, user_pref.do_fortran_indexing, "column", nc); + if (jv.length () == 0) + { + Matrix mtmp; + retval = tree_constant (mtmp); + } + else + { + range_max_check (iv.max (), jv.max (), nr, nc); + retval = do_matrix_index (iv, jv); + } + } + break; + case string_constant: + gripe_string_invalid (); + break; + case range_constant: + { + Range rj = tmp_j.range_value (); + if (nc == 2 && is_zero_one (rj)) + { + retval = do_matrix_index (iv, 1); + } + else + { + int jmax; + index_check (rj, jmax, "column"); + range_max_check (iv.max (), jmax, nr, nc); + retval = do_matrix_index (iv, rj); + } + } + break; + case magic_colon: + range_max_check (iv.max (), 0, nr, nc); + retval = do_matrix_index (iv, magic_colon); + break; + default: + panic_impossible (); + break; + } + + return retval; +} + +tree_constant +tree_constant_rep::do_matrix_index (Range& ri, int imax, tree_constant& j_arg) +{ + tree_constant retval; + + tree_constant tmp_j = j_arg.make_numeric_or_range_or_magic (); + + tree_constant_rep::constant_type jtype = tmp_j.const_type (); + + int nr = rows (); + int nc = columns (); + + switch (jtype) + { + case complex_scalar_constant: + case scalar_constant: + { + int j = tree_to_mat_idx (tmp_j.double_value ()); + index_check (j, "column"); + range_max_check (imax, j, nr, nc); + retval = do_matrix_index (ri, j); + } + break; + case complex_matrix_constant: + case matrix_constant: + { + Matrix mj = tmp_j.matrix_value (); + idx_vector jv (mj, user_pref.do_fortran_indexing, "column", nc); + if (jv.length () == 0) + { + Matrix mtmp; + retval = tree_constant (mtmp); + } + else + { + range_max_check (imax, jv.max (), nr, nc); + retval = do_matrix_index (ri, jv); + } + } + break; + case string_constant: + gripe_string_invalid (); + break; + case range_constant: + { + Range rj = tmp_j.range_value (); + if (nc == 2 && is_zero_one (rj)) + { + retval = do_matrix_index (ri, 1); + } + else + { + int jmax; + index_check (rj, jmax, "column"); + range_max_check (imax, jmax, nr, nc); + retval = do_matrix_index (ri, rj); + } + } + break; + case magic_colon: + retval = do_matrix_index (ri, magic_colon); + break; + default: + panic_impossible (); + break; + } + + return retval; +} + +tree_constant +tree_constant_rep::do_matrix_index (tree_constant_rep::constant_type mci, + tree_constant& j_arg) +{ + tree_constant retval; + + tree_constant tmp_j = j_arg.make_numeric_or_range_or_magic (); + + tree_constant_rep::constant_type jtype = tmp_j.const_type (); + + int nr = rows (); + int nc = columns (); + + switch (jtype) + { + case complex_scalar_constant: + case scalar_constant: + { + int j = tree_to_mat_idx (tmp_j.double_value ()); + index_check (j, "column"); + range_max_check (0, j, nr, nc); + retval = do_matrix_index (magic_colon, j); + } + break; + case complex_matrix_constant: + case matrix_constant: + { + Matrix mj = tmp_j.matrix_value (); + idx_vector jv (mj, user_pref.do_fortran_indexing, "column", nc); + if (jv.length () == 0) + { + Matrix mtmp; + retval = tree_constant (mtmp); + } + else + { + range_max_check (0, jv.max (), nr, nc); + retval = do_matrix_index (magic_colon, jv); + } + } + break; + case string_constant: + gripe_string_invalid (); + break; + case range_constant: + { + Range rj = tmp_j.range_value (); + if (nc == 2 && is_zero_one (rj)) + { + retval = do_matrix_index (magic_colon, 1); + } + else + { + int jmax; + index_check (rj, jmax, "column"); + range_max_check (0, jmax, nr, nc); + retval = do_matrix_index (magic_colon, rj); + } + } + break; + case magic_colon: + retval = do_matrix_index (magic_colon, magic_colon); + break; + default: + panic_impossible (); + break; + } + + return retval; +} + +tree_constant +tree_constant_rep::do_matrix_index (int i, int j) +{ + tree_constant retval; + + if (type_tag == matrix_constant) + retval = tree_constant (matrix->elem (i, j)); + else + retval = tree_constant (complex_matrix->elem (i, j)); + + return retval; +} + +tree_constant +tree_constant_rep::do_matrix_index (int i, idx_vector& jv) +{ + tree_constant retval; + + int jlen = jv.capacity (); + + CRMATRIX (m, cm, 1, jlen); + + for (int j = 0; j < jlen; j++) + { + int col = jv.elem (j); + CRMATRIX_ASSIGN_REP_ELEM (m, cm, 0, j, i, col); + } + ASSIGN_CRMATRIX_TO (retval, m, cm); + + return retval; +} + +tree_constant +tree_constant_rep::do_matrix_index (int i, Range& rj) +{ + tree_constant retval; + + int jlen = rj.nelem (); + + CRMATRIX (m, cm, 1, jlen); + + double b = rj.base (); + double increment = rj.inc (); + for (int j = 0; j < jlen; j++) + { + double tmp = b + j * increment; + int col = tree_to_mat_idx (tmp); + CRMATRIX_ASSIGN_REP_ELEM (m, cm, 0, j, i, col); + } + + ASSIGN_CRMATRIX_TO (retval, m, cm); + + return retval; +} + +tree_constant +tree_constant_rep::do_matrix_index (int i, + tree_constant_rep::constant_type mcj) +{ + assert (mcj == magic_colon); + + tree_constant retval; + + int nc = columns (); + + CRMATRIX (m, cm, 1, nc); + + for (int j = 0; j < nc; j++) + { + CRMATRIX_ASSIGN_REP_ELEM (m, cm, 0, j, i, j); + } + + ASSIGN_CRMATRIX_TO (retval, m, cm); + + return retval; +} + +tree_constant +tree_constant_rep::do_matrix_index (idx_vector& iv, int j) +{ + tree_constant retval; + + int ilen = iv.capacity (); + + CRMATRIX (m, cm, ilen, 1); + + for (int i = 0; i < ilen; i++) + { + int row = iv.elem (i); + CRMATRIX_ASSIGN_REP_ELEM (m, cm, i, 0, row, j); + } + + ASSIGN_CRMATRIX_TO (retval, m, cm); + + return retval; +} + +tree_constant +tree_constant_rep::do_matrix_index (idx_vector& iv, idx_vector& jv) +{ + tree_constant retval; + + int ilen = iv.capacity (); + int jlen = jv.capacity (); + + CRMATRIX (m, cm, ilen, jlen); + + for (int i = 0; i < ilen; i++) + { + int row = iv.elem (i); + for (int j = 0; j < jlen; j++) + { + int col = jv.elem (j); + CRMATRIX_ASSIGN_REP_ELEM (m, cm, i, j, row, col); + } + } + + ASSIGN_CRMATRIX_TO (retval, m, cm); + + return retval; +} + +tree_constant +tree_constant_rep::do_matrix_index (idx_vector& iv, Range& rj) +{ + tree_constant retval; + + int ilen = iv.capacity (); + int jlen = rj.nelem (); + + CRMATRIX (m, cm, ilen, jlen); + + double b = rj.base (); + double increment = rj.inc (); + + for (int i = 0; i < ilen; i++) + { + int row = iv.elem (i); + for (int j = 0; j < jlen; j++) + { + double tmp = b + j * increment; + int col = tree_to_mat_idx (tmp); + CRMATRIX_ASSIGN_REP_ELEM (m, cm, i, j, row, col); + } + } + + ASSIGN_CRMATRIX_TO (retval, m, cm); + + return retval; +} + +tree_constant +tree_constant_rep::do_matrix_index (idx_vector& iv, + tree_constant_rep::constant_type mcj) +{ + assert (mcj == magic_colon); + + tree_constant retval; + + int nc = columns (); + int ilen = iv.capacity (); + + CRMATRIX (m, cm, ilen, nc); + + for (int j = 0; j < nc; j++) + { + for (int i = 0; i < ilen; i++) + { + int row = iv.elem (i); + CRMATRIX_ASSIGN_REP_ELEM (m, cm, i, j, row, j); + } + } + + ASSIGN_CRMATRIX_TO (retval, m, cm); + + return retval; +} + +tree_constant +tree_constant_rep::do_matrix_index (Range& ri, int j) +{ + tree_constant retval; + + int ilen = ri.nelem (); + + CRMATRIX (m, cm, ilen, 1); + + double b = ri.base (); + double increment = ri.inc (); + for (int i = 0; i < ilen; i++) + { + double tmp = b + i * increment; + int row = tree_to_mat_idx (tmp); + CRMATRIX_ASSIGN_REP_ELEM (m, cm, i, 0, row, j); + } + + ASSIGN_CRMATRIX_TO (retval, m, cm); + + return retval; +} + +tree_constant +tree_constant_rep::do_matrix_index (Range& ri, idx_vector& jv) +{ + tree_constant retval; + + int ilen = ri.nelem (); + int jlen = jv.capacity (); + + CRMATRIX (m, cm, ilen, jlen); + + double b = ri.base (); + double increment = ri.inc (); + for (int i = 0; i < ilen; i++) + { + double tmp = b + i * increment; + int row = tree_to_mat_idx (tmp); + for (int j = 0; j < jlen; j++) + { + int col = jv.elem (j); + CRMATRIX_ASSIGN_REP_ELEM (m, cm, i, j, row, col); + } + } + + ASSIGN_CRMATRIX_TO (retval, m, cm); + + return retval; +} + +tree_constant +tree_constant_rep::do_matrix_index (Range& ri, Range& rj) +{ + tree_constant retval; + + int ilen = ri.nelem (); + int jlen = rj.nelem (); + + CRMATRIX (m, cm, ilen, jlen); + + double ib = ri.base (); + double iinc = ri.inc (); + double jb = rj.base (); + double jinc = rj.inc (); + + for (int i = 0; i < ilen; i++) + { + double itmp = ib + i * iinc; + int row = tree_to_mat_idx (itmp); + for (int j = 0; j < jlen; j++) + { + double jtmp = jb + j * jinc; + int col = tree_to_mat_idx (jtmp); + + CRMATRIX_ASSIGN_REP_ELEM (m, cm, i, j, row, col); + } + } + + ASSIGN_CRMATRIX_TO (retval, m, cm); + + return retval; +} + +tree_constant +tree_constant_rep::do_matrix_index (Range& ri, + tree_constant_rep::constant_type mcj) +{ + assert (mcj == magic_colon); + + tree_constant retval; + + int nc = columns (); + + int ilen = ri.nelem (); + + CRMATRIX (m, cm, ilen, nc); + + double ib = ri.base (); + double iinc = ri.inc (); + + for (int i = 0; i < ilen; i++) + { + double itmp = ib + i * iinc; + int row = tree_to_mat_idx (itmp); + for (int j = 0; j < nc; j++) + { + CRMATRIX_ASSIGN_REP_ELEM (m, cm, i, j, row, j); + } + } + + ASSIGN_CRMATRIX_TO (retval, m, cm); + + return retval; +} + +tree_constant +tree_constant_rep::do_matrix_index (tree_constant_rep::constant_type mci, + int j) +{ + assert (mci == magic_colon); + + tree_constant retval; + + int nr = rows (); + + CRMATRIX (m, cm, nr, 1); + + for (int i = 0; i < nr; i++) + { + CRMATRIX_ASSIGN_REP_ELEM (m, cm, i, 0, i, j); + } + + ASSIGN_CRMATRIX_TO (retval, m, cm); + + return retval; +} + +tree_constant +tree_constant_rep::do_matrix_index (tree_constant_rep::constant_type mci, + idx_vector& jv) +{ + assert (mci == magic_colon); + + tree_constant retval; + + int nr = rows (); + int jlen = jv.capacity (); + + CRMATRIX (m, cm, nr, jlen); + + for (int i = 0; i < nr; i++) + { + for (int j = 0; j < jlen; j++) + { + int col = jv.elem (j); + CRMATRIX_ASSIGN_REP_ELEM (m, cm, i, j, i, col); + } + } + + ASSIGN_CRMATRIX_TO (retval, m, cm); + + return retval; +} + +tree_constant +tree_constant_rep::do_matrix_index (tree_constant_rep::constant_type mci, + Range& rj) +{ + assert (mci == magic_colon); + + tree_constant retval; + + int nr = rows (); + int jlen = rj.nelem (); + + CRMATRIX (m, cm, nr, jlen); + + double jb = rj.base (); + double jinc = rj.inc (); + + for (int j = 0; j < jlen; j++) + { + double jtmp = jb + j * jinc; + int col = tree_to_mat_idx (jtmp); + for (int i = 0; i < nr; i++) + { + CRMATRIX_ASSIGN_REP_ELEM (m, cm, i, j, i, col); + } + } + + ASSIGN_CRMATRIX_TO (retval, m, cm); + + return retval; +} + +tree_constant +tree_constant_rep::do_matrix_index (tree_constant_rep::constant_type mci, + tree_constant_rep::constant_type mcj) +{ + assert (mci == magic_colon && mcj == magic_colon); + + return tree_constant (*this); +} + +tree_constant +tree_constant_rep::do_matrix_index (tree_constant_rep::constant_type mci) +{ + assert (mci == magic_colon); + + tree_constant retval; + int nr = rows (); + int nc = columns (); + int size = nr * nc; + if (size > 0) + { + CRMATRIX (m, cm, size, 1); + int idx = 0; + for (int j = 0; j < nc; j++) + for (int i = 0; i < nr; i++) + { + CRMATRIX_ASSIGN_REP_ELEM (m, cm, idx, 0, i, j); + idx++; + } + ASSIGN_CRMATRIX_TO (retval, m, cm); + } + return retval; +} + +/* +;;; Local Variables: *** +;;; mode: C++ *** +;;; page-delimiter: "^/\\*" *** +;;; End: *** +*/ +
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/tc-inlines.h Sun Aug 08 01:13:40 1993 +0000 @@ -0,0 +1,155 @@ +// tc-inlines.cc -*- C++ -*- +/* + +Copyright (C) 1992, 1993 John W. Eaton + +This file is part of Octave. + +Octave is free software; you can redistribute it and/or modify it +under the terms of the GNU General Public License as published by the +Free Software Foundation; either version 2, or (at your option) any +later version. + +Octave is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +for more details. + +You should have received a copy of the GNU General Public License +along with Octave; see the file COPYING. If not, write to the Free +Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. + +*/ + +// Just a coupla more helper functions. + +static inline int +tree_to_mat_idx (double x) +{ + if (x > 0) + return ((int) (x + 0.5) - 1); + else + return ((int) (x - 0.5) - 1); +} + +static inline int +range_max_check (int i, int imax) +{ + i++; + if (i > imax) + { + error ("matrix index = %d exceeds maximum dimension = %d", i, imax); + jump_to_top_level (); + } +} + +static inline int +range_max_check (int i, int j, int nr, int nc) +{ + i++; + if (i > nr) + { + error ("matrix row index = %d exceeds maximum row dimension = %d", + i, nr); + jump_to_top_level (); + } + + j++; + if (j > nc) + { + error ("matrix column index = %d exceeds maximum column dimension = %d", + j, nc); + jump_to_top_level (); + } +} + +static inline int +indexed_assign_conforms (int lhs_nr, int lhs_nc, int rhs_nr, int rhs_nc) +{ + return (lhs_nr == rhs_nr && lhs_nc == rhs_nc); +} + +static inline int +is_zero_one (const Range& r) +{ + double b = r.base (); + double l = r.limit (); + return (NINT (b) == 0 && NINT (l) == 1 && r.nelem () == 2); +} + +static inline void +index_check (int i, char *rc) +{ + if (i < 0) + { + error ("invalid %s index = %d", rc, i+1); + jump_to_top_level (); + } +} + +static inline void +index_check (const Range& r, int& max_val, char *rc) +{ + double b = r.base (); + int ib = tree_to_mat_idx (b); + + if (r.nelem () < 1) + { + error ("range invalid as %s index", rc); + jump_to_top_level (); + } + + if (ib < 0) + { + error ("invalid %s index = %d", rc, ib+1); + jump_to_top_level (); + } + + double lim = r.limit (); + max_val = tree_to_mat_idx (lim); +} + +static inline void +index_check (const Range& r, char *rc) +{ + int max_val; + index_check (r, max_val, rc); +} + +static inline int +fortran_row (int i, int nr) +{ + int r; + r = i % nr; + if (r == 0) + r = nr; + return r; +} + +static inline int +fortran_column (int i, int nr) +{ + int c; + int r; + r = fortran_row (i, nr); + c = (i - r) / nr + 1; + return c; +} + +static inline int +valid_scalar_indices (tree_constant *args, int nargs) +{ + int valid = args != NULL_TREE_CONST + && ((nargs == 3 && args[2].valid_as_scalar_index () + && args[1].valid_as_scalar_index ()) + || (nargs == 2 && args[1].valid_as_scalar_index ())); + + return valid; +} + +/* +;;; Local Variables: *** +;;; mode: C++ *** +;;; page-delimiter: "^/\\*" *** +;;; End: *** +*/
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/terminals.cc Sun Aug 08 01:13:40 1993 +0000 @@ -0,0 +1,111 @@ +// terminals.cc -*- C++ -*- +/* + +Copyright (C) 1992, 1993 John W. Eaton + +This file is part of Octave. + +Octave is free software; you can redistribute it and/or modify it +under the terms of the GNU General Public License as published by the +Free Software Foundation; either version 2, or (at your option) any +later version. + +Octave is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +for more details. + +You should have received a copy of the GNU General Public License +along with Octave; see the file COPYING. If not, write to the Free +Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. + +*/ + +#ifdef __GNUG__ +#pragma implementation +#endif + +#include <stddef.h> +#include <strings.h> +#include "terminals.h" + +/* + * It would be nice to be able to get these directly from gnuplot + * during the configuration/build procedure. + */ +static char *valid_terminals[] = +{ + "unknown", + "table", + "dumb", + "aed512", + "aed767", + "bitgraph", + "dxy800a", + "eepic", + "emtex", + "epson_60dpi", + "epson_lx800", + "fig", + "bfig", + "hp2623A", + "hp2648", + "hp7580B", + "hpgl", + "hpljii", + "hpdj", + "pcl5_port", + "pcl5_land", + "imagen", + "kc_tek40", + "km_tek40", + "latex", + "nec_cp6m", + "nec_cp6c", + "nec_cp6d", + "pbm", + "pgm", + "ppm", + "postscript", + "prescribe", + "kyo", + "qms", + "regis", + "selanar", + "starc", + "tandy_60dpi", + "tek410", + "tek40", + "unixplot", + "vx384", + "vttek", + "x11", + "X11", + (char *) NULL, +}; + +/* + * Is the given terminal named in the list above? + */ +int +valid_terminal (char *term) +{ + if (term == (char *) NULL) + return 0; + + for (char **t_list = valid_terminals; *t_list != (char *) NULL; t_list++) + { + char *t = *t_list; + int len = strlen (t); + if (strncmp (term, t, len) == 0) + return 1; + } + return 0; +} + +/* +;;; Local Variables: *** +;;; mode: C++ *** +;;; page-delimiter: "^/\\*" *** +;;; End: *** +*/
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/terminals.h Sun Aug 08 01:13:40 1993 +0000 @@ -0,0 +1,40 @@ +// Available graphics terminals. -*- C++ -*- +/* + +Copyright (C) 1992, 1993 John W. Eaton + +This file is part of Octave. + +Octave is free software; you can redistribute it and/or modify it +under the terms of the GNU General Public License as published by the +Free Software Foundation; either version 2, or (at your option) any +later version. + +Octave is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +for more details. + +You should have received a copy of the GNU General Public License +along with Octave; see the file COPYING. If not, write to the Free +Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. + +*/ + +#if !defined (_terminals_h) +#define _terminals_h 1 + +#ifdef __GNUG__ +#pragma interface +#endif + +extern int valid_terminal (char *); + +#endif + +/* +;;; Local Variables: *** +;;; mode: C++ *** +;;; page-delimiter: "^/\\*" *** +;;; End: *** +*/
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/toplev.h Sun Aug 08 01:13:40 1993 +0000 @@ -0,0 +1,75 @@ +// octave.h -*- C++ -*- +/* + +Copyright (C) 1992, 1993 John W. Eaton + +This file is part of Octave. + +Octave is free software; you can redistribute it and/or modify it +under the terms of the GNU General Public License as published by the +Free Software Foundation; either version 2, or (at your option) any +later version. + +Octave is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +for more details. + +You should have received a copy of the GNU General Public License +along with Octave; see the file COPYING. If not, write to the Free +Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. + +*/ + +#if !defined (_octave_h) +#define _octave_h 1 + +#include <stdio.h> + +class tree; + +extern volatile void clean_up_and_exit (int); +extern void parse_and_execute (char*, int); +extern void parse_and_execute (FILE*, int); + +// argv[0] for this program. +extern char *raw_prog_name; + +// Cleaned-up name of this program, not including path information. +extern char *prog_name; + +// Login name for user running this program. +extern char *user_name; + +// Name of the host we are running on. +extern char *host_name; + +// User's home directory. +extern char *home_directory; + +// Guess what? +extern char *the_current_working_directory; + +// Load path specified on command line. +extern char *load_path; + +// If nonzero, don't do fancy line editing. +extern int no_line_editing; + +// Command number, counting from the beginning of this session. +extern int current_command_number; + +// Nonzero means we are exiting via the builtin exit or quit functions. +extern int quitting_gracefully; + +// Current command to execute. +extern tree *global_command; + +#endif + +/* +;;; Local Variables: *** +;;; mode: C++ *** +;;; page-delimiter: "^/\\*" *** +;;; End: *** +*/
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/tree.h.old Sun Aug 08 01:13:40 1993 +0000 @@ -0,0 +1,880 @@ +// Tree classes. -*- C++ -*- +/* + +Copyright (C) 1992, 1993 John W. Eaton + +This file is part of Octave. + +Octave is free software; you can redistribute it and/or modify it +under the terms of the GNU General Public License as published by the +Free Software Foundation; either version 2, or (at your option) any +later version. + +Octave is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +for more details. + +You should have received a copy of the GNU General Public License +along with Octave; see the file COPYING. If not, write to the Free +Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. + +*/ + +#if !defined (_tree_h) +#define _tree_h 1 + +// This seems to leave vt$tree undefined with g++ 2.3.3. +#if 0 +#ifdef __GNUG__ +#pragma interface +#endif +#endif + +#include <stdio.h> + +class ostrstream; + +#include "builtins.h" +#include "tree-base.h" +#include "tree-const.h" + +class symbol_record; +class symbol_table; + +#ifndef TREE_FCN_TYPEDEFS +#define TREE_FCN_TYPEDEFS 1 + +typedef tree_constant (*Text_fcn)(int, char **); +typedef tree_constant* (*General_fcn)(tree_constant *, int, int); + +#endif + +#ifndef NULL_TREE +#define NULL_TREE (tree *) NULL +#endif + +#ifndef NULL_TREE_CONST +#define NULL_TREE_CONST (tree_constant *) NULL +#endif + +/* + * Forward declarations. + */ +class tree; +class tree_constant_rep; +class tree_constant; +class tree_matrix; +class tree_builtin; +class tree_identifier; +class tree_function; +class tree_expression; +class tree_prefix_expression; +class tree_postfix_expression; +class tree_unary_expression; +class tree_binary_expression; +class tree_assignment_expression; +class tree_simple_assignment_expression; +class tree_multi_assignment_expression; +class tree_colon_expression; +class tree_index_expression; +class tree_argument_list; +class tree_parameter_list; +class tree_return_list; +class tree_word_list; +class tree_command; +class tree_command_list; +class tree_while_command; +class tree_for_command; +class tree_if_command; +class tree_break_command; +class tree_continue_command; +class tree_return_command; +class tree_word_list_command;; +class tree_plot_limits; +class tree_plot_range; +class tree_subplot; +class tree_subplot_using; +class tree_subplot_style; +class tree_subplot_list; +class tree_plot_command; + +/* + * General matrices. This allows us to construct matrices from + * other matrices, variables, and functions. + */ +class +tree_matrix : public tree +{ +public: + tree_matrix (void); + tree_matrix (tree *t, tree::matrix_dir d); + + ~tree_matrix (void); + + tree_matrix *chain (tree *t, tree::matrix_dir d); + tree_matrix *reverse (void); + int length (void); + + tree_return_list *to_return_list (void); + + tree_constant eval (int print); + +private: + tree::matrix_dir dir; // Direction to the next element. + tree *element; + tree_matrix *next; +}; + +/* + * Builtin functions. + */ +class +tree_builtin : public tree +{ +public: + tree_builtin (void); + tree_builtin (int i_max, int o_max, Mapper_fcn& m_fcn, symbol_record *s); + tree_builtin (int i_max, int o_max, Text_fcn t_fcn, symbol_record *s); + tree_builtin (int i_max, int o_max, General_fcn t_fcn, symbol_record *s); + + ~tree_builtin (void); + + int is_builtin (void); + + tree_constant eval (int print); + + tree_constant *eval (int print, int nargout); + + tree_constant eval (int argc, char **argv, int print); + + tree_constant *eval (tree_constant *args, int n_in, int n_out, int print); + + tree *def (void); + char *name (void); + + int max_expected_args (void); + +private: + int nargin_max; + int nargout_max; + Mapper_fcn mapper_fcn; + Text_fcn text_fcn; + General_fcn general_fcn; + symbol_record *sym; // Is this really needed? It points back + // to the symbol record that contains this + // builtin function... +}; + +/* + * Symbols from the symbol table. + */ +class +tree_identifier : public tree +{ + friend class tree_index_expression; + +public: + tree_identifier (void); + tree_identifier (symbol_record *s); + + ~tree_identifier (void); + + int is_identifier (void); + + tree *def (void); + char *name (void); + symbol_record *symrec (void); + + tree_identifier *define (tree_constant *t); + tree_identifier *define (tree_function *t); + + void document (char *s); + + tree_constant assign (tree_constant& t); + tree_constant assign (tree_constant& t, tree_constant *args, int nargs); + + void bump_value (tree::expression_type); + + int parse_m_file (int exec_script = 1); + int parse_m_file (char *mf, int exec_script = 1); + void parse_m_file (FILE *mfile, char *mf); + + tree *do_lookup (int& script_file_executed); + + void mark_as_formal_parameter (void); + + tree_constant eval (int print); + + tree_constant *eval (int print, int nargout); + + tree_constant eval (int argc, char **argv, int print); + + tree_constant *eval (tree_constant *args, int n_in, int n_out, int print); + + void eval_undefined_error (void); + +private: + symbol_record *sym; +}; + +/* + * User defined functions. + */ +class +tree_function : public tree +{ +public: + tree_function (void); + tree_function (tree *cl, symbol_table *st); + + ~tree_function (void); + + tree_function *define (tree *t); + tree_function *define_param_list (tree_parameter_list *t); + tree_function *define_ret_list (tree_parameter_list *t); + + void stash_m_file_name (char * s); + void stash_m_file_time (time_t t); + + char *m_file_name (void); + time_t time_parsed (void); + + tree_constant eval (int print); + + tree_constant *eval (int print, int nargout); + + tree_constant eval (int argc, char **argv, int print); + + tree_constant *eval (tree_constant *args, int n_in, int n_out, int print); + + int max_expected_args (void); + +private: + int call_depth; + tree_parameter_list *param_list; + tree_parameter_list *ret_list; + symbol_table *sym_tab; + tree *cmd_list; + time_t t_parsed; + char *file_name; +}; + +/* + * A base class for expressions. + */ +class +tree_expression : public tree +{ +public: + tree_expression (void); + + ~tree_expression (void); + + tree_constant eval (int print); + +protected: + expression_type etype; +}; + +/* + * Prefix expressions. + */ +class +tree_prefix_expression : public tree_expression +{ + public: + tree_prefix_expression (void); + tree_prefix_expression (tree_identifier *t, tree::expression_type et); + + ~tree_prefix_expression (void); + + tree_constant eval (int print); + + private: + tree_identifier *id; +}; + +/* + * Postfix expressions. + */ +class +tree_postfix_expression : public tree_expression +{ + public: + tree_postfix_expression (void); + tree_postfix_expression (tree_identifier *t, tree::expression_type et); + + ~tree_postfix_expression (void); + + tree_constant eval (int print); + + private: + tree_identifier *id; +}; + +/* + * Unary expressions. + */ +class +tree_unary_expression : public tree_expression +{ + public: + tree_unary_expression (void); + tree_unary_expression (tree *a, tree::expression_type t); + + ~tree_unary_expression (void); + + tree_constant eval (int print); + + private: + tree *op; +}; + +/* + * Binary expressions. + */ +class +tree_binary_expression : public tree_expression +{ + public: + tree_binary_expression (void); + tree_binary_expression (tree *a, tree *b, tree::expression_type t); + + ~tree_binary_expression (void); + + tree_constant eval (int print); + + private: + tree *op1; + tree *op2; +}; + +/* + * Assignment expressions. + */ +class +tree_assignment_expression : public tree_expression +{ +public: + int in_parens; + + tree_assignment_expression (void); + + ~tree_assignment_expression (void); + + tree_constant eval (int print); + + int is_assignment_expression (void); +}; + +/* + * Simple assignment expressions. + */ +class +tree_simple_assignment_expression : public tree_assignment_expression +{ + public: + tree_simple_assignment_expression (void); + tree_simple_assignment_expression (tree_identifier *i, tree *r); + tree_simple_assignment_expression (tree_index_expression *idx_expr, tree *r); + + ~tree_simple_assignment_expression (void); + + tree_constant eval (int print); + + private: + tree_identifier *lhs; + tree_argument_list *index; + tree *rhs; +}; + +/* + * Multi-valued assignment expressions. + */ +class +tree_multi_assignment_expression : public tree_assignment_expression +{ + public: + tree_multi_assignment_expression (void); + tree_multi_assignment_expression (tree_return_list *l, tree *r); + + ~tree_multi_assignment_expression (void); + + tree_constant eval (int print); + + tree_constant *eval (int print, int nargout); + + private: + tree_return_list *lhs; + tree *rhs; +}; + +/* + * Colon expressions. + */ +class +tree_colon_expression : public tree_expression +{ + public: + tree_colon_expression (void); + tree_colon_expression (tree *a, tree *b); + + ~tree_colon_expression (void); + + tree_colon_expression *chain (tree *t); + + tree_constant eval (int print); + + private: + tree *op1; + tree *op2; + tree *op3; +}; + +/* + * Index expressions. + */ +class +tree_index_expression : public tree_expression +{ + public: + tree_index_expression (void); + tree_index_expression (tree_identifier *i); + tree_index_expression (tree_identifier *i, tree_argument_list *l); + + ~tree_index_expression (void); + + int is_index_expression (void); + + tree_identifier *ident (void); + + tree_argument_list *arg_list (void); + + tree_constant eval (int print); + + tree_constant *eval (int print, int nargout); + + private: + tree_identifier *id; + tree_argument_list *list; +}; + +/* + * Argument lists. + */ +class +tree_argument_list : public tree +{ + public: + tree_argument_list (void); + tree_argument_list (tree *t); + + ~tree_argument_list (void); + + tree_argument_list *chain (tree *t); + tree_argument_list *reverse (void); + int length (void); + + tree_argument_list *next_elem (void); + + tree_constant *convert_to_const_vector (int& nargs); + + tree_constant eval (int print); + + private: + tree *arg; + tree_argument_list *next; +}; + +/* + * Parameter lists. Almost like argument lists, except that the + * elements are only supposed to be identifiers, never constants or + * expressions. + */ +class +tree_parameter_list : public tree +{ + public: + tree_parameter_list (void); + tree_parameter_list (tree_identifier *t); + + ~tree_parameter_list (void); + + tree_parameter_list *chain (tree_identifier *t); + tree_parameter_list *reverse (void); + int length (void); + + char *name (void); + + void mark_as_formal_parameters (void); + + tree_identifier *define (tree_constant *t); + + tree_parameter_list *next_elem (void); + + tree_constant eval (int print); + + private: + tree_identifier *param; + tree_parameter_list *next; +}; + +/* + * Return lists. Almost like parameter lists, except that the + * elements may also be index expressions. + */ +class +tree_return_list : public tree +{ + public: + tree_return_list (void); + tree_return_list (tree_identifier *t); + tree_return_list (tree_index_expression *t); + + ~tree_return_list (void); + + tree_return_list *chain (tree_identifier *t); + tree_return_list *chain (tree_index_expression *t); + tree_return_list *reverse (void); + int length (void); + + tree_index_expression *idx_expr (void); + + tree_return_list *next_elem (void); + + tree_constant eval (int print); + + private: + tree_index_expression *retval; + tree_return_list *next; +}; + +/* + * Word lists. + */ +class +tree_word_list : public tree +{ + public: + tree_word_list (void); + tree_word_list (char *s); + + ~tree_word_list (void); + + tree_word_list *chain (char *s); + tree_word_list *reverse (void); + int length (void); + + char *name (void); + + tree_word_list *next_elem (void); + + tree_constant eval (int print); + + private: + char *word; + tree_word_list *next; +}; + +/* + * A base class for commands. + */ +class +tree_command : public tree +{ +}; + +/* + * A command or two to be executed. + */ +class +tree_command_list : public tree_command +{ + public: + tree_command_list (void); + tree_command_list (tree *t); + + ~tree_command_list (void); + + tree_command_list *chain (tree *t); + tree_command_list *reverse (void); + + void set_print_flag (int print); + + tree_constant eval (int print); + + private: + tree *command; // Command to execute. + int print_flag; // Print result of eval for this command? + tree_command_list *next; // Next command in list. +}; + +/* + * While. + */ +class +tree_while_command : public tree_command +{ + public: + tree_while_command (void); + tree_while_command (tree *e); + tree_while_command (tree *e, tree *l); + + ~tree_while_command (void); + + tree_constant eval (int print); + + private: + tree *expr; // Expression to test. + tree *list; // List of commands to execute. +}; + +/* + * For. + */ +class +tree_for_command : public tree_command +{ + public: + tree_for_command (void); + tree_for_command (tree_identifier *id, tree *e, tree *l); + + ~tree_for_command (void); + + tree_constant eval (int print); + + private: + tree_identifier *id; // Identifier to modify. + tree *expr; // Expression to evaluate. + tree *list; // List of commands to execute. +}; + +/* + * Simple if. + */ +class +tree_if_command : public tree_command +{ + public: + tree_if_command (void); + tree_if_command (tree *t); + tree_if_command (tree *e, tree *t); + + ~tree_if_command (void); + + tree_if_command *chain (tree *t); + tree_if_command *chain (tree *t1, tree *t2); + tree_if_command *reverse (void); + + tree_constant eval (int print); + + private: + tree *expr; // Expression to test. + tree *list; // Commands to execute. + tree_if_command *next; // Next if command. +}; + +/* + * Break. + */ +class +tree_break_command : public tree_command +{ + public: + tree_break_command (void); + + ~tree_break_command (void); + + tree_constant eval (int print); +}; + +/* + * Continue. + */ +class +tree_continue_command : public tree_command +{ + public: + tree_continue_command (void); + + ~tree_continue_command (void); + + tree_constant eval (int print); +}; + +/* + * Return. + */ +class +tree_return_command : public tree_command +{ + public: + tree_return_command (void); + + ~tree_return_command (void); + + tree_constant eval (int print); +}; + +/* + * Functions that take a list of strings as arguments. + */ +class +tree_word_list_command : public tree_command +{ + public: + tree_word_list_command (void); + tree_word_list_command (tree_identifier *id, tree_word_list *wl); + + ~tree_word_list_command (void); + + tree_constant eval (int print); + + private: + tree_identifier *ident; + tree_word_list *word_list; +}; + +class +tree_plot_command : public tree_command +{ + public: + tree_plot_command (void); + tree_plot_command (tree_subplot_list *plt, int nd); + tree_plot_command (tree_subplot_list *plt, tree_plot_limits *rng, int nd); + + ~tree_plot_command (void); + + tree_constant eval (int print); + + private: + int ndim; + tree_plot_limits *range; + tree_subplot_list *plot_list; +}; + +class +tree_subplot_list : public tree +{ + public: + tree_subplot_list (void); + tree_subplot_list (tree *data); + tree_subplot_list (tree_subplot_list *t); + tree_subplot_list (tree_subplot_using *u, tree *t, tree_subplot_style *s); + + ~tree_subplot_list (void); + + tree_subplot_list *set_data (tree *data); + + tree_subplot_list *chain (tree_subplot_list *t); + + tree_subplot_list *reverse (void); + + tree_subplot_list *next_elem (void); + + tree_constant eval (int print); +// tree_constant *eval (int print, int nargout); + + int print (int ndim, ostrstream& plot_buf); + + private: + tree *plot_data; + tree_subplot_using *using; + tree *title; + tree_subplot_style *style; + tree_subplot_list *next; +}; + +class +tree_plot_limits : public tree +{ + public: + tree_plot_limits (void); + tree_plot_limits (tree_plot_range *xlim); + tree_plot_limits (tree_plot_range *xlim, tree_plot_range *ylim); + tree_plot_limits (tree_plot_range *xlim, tree_plot_range *ylim, + tree_plot_range *zlim); + + ~tree_plot_limits (void); + + tree_constant eval (int print); + + void print (int print, ostrstream& plot_buf); + + private: + tree_plot_range *x_range; + tree_plot_range *y_range; + tree_plot_range *z_range; +}; + +class +tree_plot_range : public tree +{ + public: + tree_plot_range (void); + tree_plot_range (tree *l, tree *u); + + ~tree_plot_range (void); + + tree_constant eval (int print); + + void print (ostrstream& plot_buf); + + private: + tree *lower; + tree *upper; +}; + +class +tree_subplot_using : public tree +{ + public: + tree_subplot_using (void); + tree_subplot_using (tree *fmt); + + ~tree_subplot_using (void); + + tree_subplot_using *set_format (tree *fmt); + + tree_subplot_using *add_qualifier (tree *t); + + tree_constant eval (int print); + + int print (int ndim, int n_max, ostrstream& plot_buf); + + private: + int qualifier_count; + tree *x[4]; + tree *scanf_fmt; +}; + +class +tree_subplot_style : public tree +{ + public: + tree_subplot_style (void); + tree_subplot_style (char *s); + tree_subplot_style (char *s, tree *lt); + tree_subplot_style (char *s, tree *lt, tree *pt); + + ~tree_subplot_style (void); + + tree_constant eval (int print); + + int print (ostrstream& plot_buf); + + private: + char *style; + tree *linetype; + tree *pointtype; +}; + +#endif + +/* +;;; Local Variables: *** +;;; mode: C++ *** +;;; page-delimiter: "^/\\*" *** +;;; End: *** +*/
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/unwind-prot.cc Sun Aug 08 01:13:40 1993 +0000 @@ -0,0 +1,334 @@ +// unwind-prot.cc -*- C++ -*- +/* + +Copyright (C) 1992, 1993 John W. Eaton + +This file is part of Octave. + +Octave is free software; you can redistribute it and/or modify it +under the terms of the GNU General Public License as published by the +Free Software Foundation; either version 2, or (at your option) any +later version. + +Octave is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +for more details. + +You should have received a copy of the GNU General Public License +along with Octave; see the file COPYING. If not, write to the Free +Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. + +*/ + +#ifdef __GNUG__ +#pragma implementation +#endif + +#include <stddef.h> + +#include "SLStack.h" + +#include "Matrix.h" + +#include "unwind-prot.h" +#include "error.h" +#include "utils.h" + +class unwind_elem +{ + public: + unwind_elem (void); + unwind_elem (char *t); + unwind_elem (cleanup_func f, void *p); + unwind_elem (const unwind_elem& el); + ~unwind_elem (void); + + unwind_elem& operator = (const unwind_elem& el); + + char *tag (void); + cleanup_func fptr (void); + void *ptr (void); + + private: + char *_tag; + cleanup_func _fptr; + void *_ptr; +}; + +unwind_elem::unwind_elem (void) +{ + _tag = (char *) NULL; + _fptr = (cleanup_func) NULL; + _ptr = (void *) NULL; +} + +unwind_elem::unwind_elem (char *t) +{ + _tag = strsave (t); + _fptr = (cleanup_func) NULL; + _ptr = (void *) NULL; +} + +unwind_elem::unwind_elem (cleanup_func f, void *p) +{ + _tag = (char *) NULL; + _fptr = f; + _ptr = p; +} + +unwind_elem::unwind_elem (const unwind_elem& el) +{ + _tag = strsave (el._tag); + _fptr = el._fptr; + _ptr = el._ptr; +} + +unwind_elem::~unwind_elem (void) +{ + delete [] _tag; +} + +unwind_elem& +unwind_elem::operator = (const unwind_elem& el) +{ + _tag = strsave (el._tag); + _fptr = el._fptr; + _ptr = el._ptr; + + return *this; +} + +char * +unwind_elem::tag (void) +{ + return _tag; +} + +cleanup_func +unwind_elem::fptr (void) +{ + return _fptr; +} + +void * +unwind_elem::ptr (void) +{ + return _ptr; +} + +static SLStack <unwind_elem> unwind_protect_list; + +void +add_unwind_protect (cleanup_func fptr, void *ptr) +{ + unwind_elem el (fptr, ptr); + unwind_protect_list.push (el); +} + +void +run_unwind_protect (void) +{ + unwind_elem el = unwind_protect_list.pop (); + + cleanup_func f = el.fptr (); + if (f != (cleanup_func) NULL) + f (el.ptr ()); +} + +void +discard_unwind_protect (void) +{ + unwind_protect_list.pop (); +} + +void +begin_unwind_frame (char *tag) +{ + unwind_elem elem (tag); + unwind_protect_list.push (elem); +} + +void +run_unwind_frame (char *tag) +{ + while (! unwind_protect_list.empty ()) + { + unwind_elem el = unwind_protect_list.pop (); + + cleanup_func f = el.fptr (); + if (f != (cleanup_func) NULL) + f (el.ptr ()); + + char *t = el.tag (); + if (t != (char *) NULL && strcmp (t, tag) == 0) + break; + } +} + +void +discard_unwind_frame (char *tag) +{ + while (! unwind_protect_list.empty ()) + { + unwind_elem el = unwind_protect_list.pop (); + char *t = el.tag (); + if (t != (char *) NULL && strcmp (t, tag) == 0) + break; + } +} + +void +run_all_unwind_protects (void) +{ + while (! unwind_protect_list.empty ()) + { + unwind_elem el = unwind_protect_list.pop (); + + cleanup_func f = el.fptr (); + if (f != (cleanup_func) NULL) + f (el.ptr ()); + } +} + +void +discard_all_unwind_protects (void) +{ + unwind_protect_list.clear (); +} + +void +matrix_cleanup (void *m) +{ + delete [] (double *) m; +} + +void +complex_matrix_cleanup (void *cm) +{ + delete [] (ComplexMatrix *) cm; +} + +class saved_variable +{ + public: + enum var_type { integer, generic_ptr, generic }; + + saved_variable (void); + saved_variable (int *p, int v); + saved_variable (void **p, void *v); + saved_variable (void *p, void *v, size_t sz); + ~saved_variable (void); + + void restore_value (void); + + private: + union + { + int *ptr_to_int; + void *gen_ptr; + void **ptr_to_gen_ptr; + }; + + union + { + int int_value; + void *gen_ptr_value; + }; + + var_type type_tag; + size_t size; +}; + +saved_variable::saved_variable (void) +{ + gen_ptr = (void *) NULL; + gen_ptr_value = (void *) NULL; + type_tag = generic; + size = 0; +} + +saved_variable::saved_variable (int *p, int v) +{ + type_tag = integer; + ptr_to_int = p; + int_value = v; + size = sizeof (int); +} + +saved_variable::saved_variable (void **p, void *v) +{ + type_tag = generic_ptr; + ptr_to_gen_ptr = p; + gen_ptr_value = v; + size = sizeof (void *); +} + +saved_variable::saved_variable (void *p, void *v, size_t sz) +{ + gen_ptr = v; + gen_ptr_value = new char [sz]; + memcpy (gen_ptr_value, v, sz); + size = sz; +} + +saved_variable::~saved_variable (void) +{ + if (type_tag == generic) + delete [] gen_ptr_value; +} + +void +saved_variable::restore_value (void) +{ + switch (type_tag) + { + case integer: + *ptr_to_int = int_value; + break; + case generic_ptr: + *ptr_to_gen_ptr = gen_ptr_value; + break; + case generic: + memcpy (gen_ptr, gen_ptr_value, size); + break; + default: + panic_impossible (); + } +} + +static void +restore_saved_variable (void *s) +{ + saved_variable *sv = (saved_variable *) s; + sv->restore_value (); + delete sv; +} + +void +unwind_protect_int_internal (int *ptr, int value) +{ + saved_variable *s = new saved_variable (ptr, value); + add_unwind_protect (restore_saved_variable, (void *) s); +} + +void +unwind_protect_ptr_internal (void **ptr, void *value) +{ + saved_variable *s = new saved_variable (ptr, value); + add_unwind_protect (restore_saved_variable, (void *) s); +} + +void +unwind_protect_var_internal (void *ptr, void *value, size_t size) +{ + saved_variable *s = new saved_variable (ptr, value, size); + add_unwind_protect (restore_saved_variable, (void *) s); +} + +/* +;;; Local Variables: *** +;;; mode: C++ *** +;;; page-delimiter: "^/\\*" *** +;;; End: *** +*/
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/unwind-prot.h Sun Aug 08 01:13:40 1993 +0000 @@ -0,0 +1,67 @@ +// unwind-prot.h -*- C++ -*- +/* + +Copyright (C) 1992, 1993 John W. Eaton + +This file is part of Octave. + +Octave is free software; you can redistribute it and/or modify it +under the terms of the GNU General Public License as published by the +Free Software Foundation; either version 2, or (at your option) any +later version. + +Octave is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +for more details. + +You should have received a copy of the GNU General Public License +along with Octave; see the file COPYING. If not, write to the Free +Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. + +*/ + +#if !defined (_unwind_prot_h) +#define _unwind_prot_h 1 + +#ifdef __GNUG__ +#pragma interface +#endif + +#include <stddef.h> + +typedef void (*cleanup_func)(void *ptr); + +void add_unwind_protect (cleanup_func fptr, void *ptr); +void run_unwind_protect (void); +void discard_unwind_protect (void); +void begin_unwind_frame (char *tag); +void run_unwind_frame (char *tag); +void discard_unwind_frame (char *tag); +void run_all_unwind_protects (void); +void discard_all_unwind_protects (void); + +void matrix_cleanup (void *m); +void complex_matrix_cleanup (void *cm); + +void unwind_protect_int_internal (int *ptr, int value); +void unwind_protect_ptr_internal (void **ptr, void *value); +void unwind_protect_var_internal (void *ptr, void *value, size_t size); + +#define unwind_protect_int(i) \ + unwind_protect_int_internal (&(i), (i)) + +#define unwind_protect_ptr(p) \ + unwind_protect_ptr_internal ((void **) &(p), (void *) (p)) + +#define unwind_protect_var(i) \ + unwind_protect_var_internal ((void *) &(i), (void *) &(i), sizeof (int)) + +#endif + +/* +;;; Local Variables: *** +;;; mode: C++ *** +;;; page-delimiter: "^/\\*" *** +;;; End: *** +*/
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/user-prefs.cc Sun Aug 08 01:13:40 1993 +0000 @@ -0,0 +1,504 @@ +// user-prefs.cc -*- C++ -*- +/* + +Copyright (C) 1992, 1993 John W. Eaton + +This file is part of Octave. + +Octave is free software; you can redistribute it and/or modify it +under the terms of the GNU General Public License as published by the +Free Software Foundation; either version 2, or (at your option) any +later version. + +Octave is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +for more details. + +You should have received a copy of the GNU General Public License +along with Octave; see the file COPYING. If not, write to the Free +Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. + +*/ + +#ifdef __GNUG__ +#pragma implementation +#endif + +#include <string.h> + +#include "user-prefs.h" +#include "error.h" +#include "variables.h" +#include "utils.h" + +// The list of user preferences. Values change when global variables +// change, so we don\'t have to do a variable look up every time we +// need to check a preference. +user_preferences user_pref; + +/* + * Check the value of a string variable to see if it it\'s ok to do + * something. + * + * return of -1 => ok, but give me warning (default). + * return of 0 => always ok. + * return of 1 => never ok. + */ +static int +check_str_pref (char *var) +{ + char *val = octave_string_variable (var); + int pref = -1; + if (val != (char *) NULL) + { + if (strncmp (val, "yes", 3) == 0 + || strncmp (val, "true", 4) == 0) + pref = 1; + else if (strncmp (val, "never", 5) == 0 + || strncmp (val, "no", 2) == 0 + || strncmp (val, "false", 5) == 0) + pref = 0; + } + return pref; +} + +/* + * Should we allow assignments like: + * + * octave> A(1) = 3; A(2) = 5 + * + * for A already defined and a matrix type? + */ +int +do_fortran_indexing (void) +{ + user_pref.do_fortran_indexing = + check_str_pref ("do_fortran_indexing"); + + return 0; +} + +/* + * Should ignore empty elements in a matrix list (i.e., is an + * expression like `[[], 1]' ok? + */ +int +empty_list_elements_ok (void) +{ + user_pref.empty_list_elements_ok = + check_str_pref ("empty_list_elements_ok"); + + return 0; +} + +/* + * Should we allow things like: + * + * octave> 'abc' + 0 + * 97 98 99 + * + * to happen? + */ +int +implicit_str_to_num_ok (void) +{ + user_pref.implicit_str_to_num_ok = + check_str_pref ("implicit_str_to_num_ok"); + + return 0; +} + +/* + * Should we allow silent conversion of complex to real when a real + * type is what we\'re really looking for? + */ +int +ok_to_lose_imaginary_part (void) +{ + user_pref.ok_to_lose_imaginary_part = + check_str_pref ("ok_to_lose_imaginary_part"); + + return 0; +} + +/* + * When doing assignments like: + * + * octave> A(1) = 3; A(2) = 5 + * + * (for A undefined) should we build column vectors? Returning true + * only matters when resize_on_range_error is also true. + */ +int +prefer_column_vectors (void) +{ + user_pref.prefer_column_vectors = + check_str_pref ("prefer_column_vectors"); + + return 0; +} + +/* + * For things like + * + * a = [2,3]; a([1,1]) + * + * return [2 3] instead of [2 2]. + */ +int +prefer_zero_one_indexing (void) +{ + user_pref.prefer_zero_one_indexing = + check_str_pref ("prefer_zero_one_indexing"); + + return 0; +} + +/* + * Should we print things like + * + * octave> a = [1,2;3,4] + * a = + * + * 1 2 + * 3 4 + */ +int +print_answer_id_name (void) +{ + user_pref.print_answer_id_name = + check_str_pref ("print_answer_id_name"); + + return 0; +} + +/* + * Should operations on empty matrices return empty matrices or an + * error? + */ +int +propagate_empty_matrices (void) +{ + user_pref.propagate_empty_matrices = + check_str_pref ("propagate_empty_matrices"); + + return 0; +} + +/* + * Should we also print the dimensions of empty matrices? + */ +int +print_empty_dimensions (void) +{ + user_pref.print_empty_dimensions = + check_str_pref ("print_empty_dimensions"); + + return 0; +} + +/* + * When doing assignments, should we resize matrices if the indices + * are outside the current bounds? + */ +int +resize_on_range_error (void) +{ + user_pref.resize_on_range_error = + check_str_pref ("resize_on_range_error"); + + return 0; +} + +/* + * If a function does not return any values explicitly, return the + * last computed value. + */ +int +return_last_computed_value (void) +{ + user_pref.return_last_computed_value = + check_str_pref ("return_last_computed_value"); + + return 0; +} + +/* + * Suppress printing results in called functions. + */ +int +silent_functions (void) +{ + user_pref.silent_functions = + check_str_pref ("silent_functions"); + + return 0; +} + +/* + * Should should big matrices be split into smaller slices for output? + */ +int +split_long_rows (void) +{ + user_pref.split_long_rows = check_str_pref ("split_long_rows"); + + return 0; +} + +/* + * Should things like: + * + * octave> ones (-1, 5) + * + * result in an empty matrix or an error? + */ +int +treat_neg_dim_as_zero (void) +{ + user_pref.treat_neg_dim_as_zero = + check_str_pref ("treat_neg_dim_as_zero"); + + return 0; +} + +/* + * Generate a warning for the comma in things like + * + * octave> global a, b = 2 + */ +int +warn_comma_in_global_decl (void) +{ + user_pref.warn_comma_in_global_decl = + check_str_pref ("warn_comma_in_global_decl"); + + return 0; +} + +/* + * On IEEE machines, allow divide by zero errors to be suppressed. + */ +int +warn_divide_by_zero (void) +{ + user_pref.warn_divide_by_zero = check_str_pref ("warn_divide_by_zero"); + + return 0; +} + +/* + * Generate a warning for the assignment in things like + * + * octave> if (a = 2 < n) + * + * but not + * + * octave> if ((a = 2) < n) + */ +int +warn_assign_as_truth_value (void) +{ + user_pref.warn_assign_as_truth_value = + check_str_pref ("user_pref.warn_assign_as_truth_value"); + + return 0; +} + +/* + * If possible, send all output intended for the screen through the + * pager. + */ +int +page_screen_output (void) +{ + user_pref.page_screen_output = check_str_pref ("page_screen_output"); + + return 0; +} + +int +set_output_max_field_width (void) +{ + int status = 0; + + static int kludge = 0; + + double val; + if (octave_real_scalar_variable ("output_max_field_width", val) == 0) + { + int ival = NINT (val); + if (ival > 0 && (double) ival == val) + { + user_pref.output_max_field_width= ival; + return status; + } + } + + if (kludge == 0) + kludge++; + else + { + warning ("invalid value specified for output_max_field_width"); + status = -1; + } + + return status; +} + +int +set_output_precision (void) +{ + int status = 0; + + static int kludge = 0; + + double val; + if (octave_real_scalar_variable ("output_precision", val) == 0) + { + int ival = NINT (val); + if (ival >= 0 && (double) ival == val) + { + user_pref.output_precision = ival; + return status; + } + } + + if (kludge == 0) + kludge++; + else + { + warning ("invalid value specified for output_precision"); + status = -1; + } + + return status; +} + +int +sv_loadpath (void) +{ + int status = 0; + + char *s = octave_string_variable ("LOADPATH"); + if (s != (char *) NULL) + { + delete [] user_pref.loadpath; + user_pref.loadpath = s; + } + else + { + warning ("invalid value specified for LOADPATH"); + status = -1; + } + + return status; +} + +int +sv_ps1 (void) +{ + int status = 0; + + char *s = octave_string_variable ("PS1"); + if (s != (char *) NULL) + { + delete [] user_pref.ps1; + user_pref.ps1 = s; + } + else + { + warning ("invalid value specified for PS1"); + status = -1; + } + + return status; +} + +int +sv_ps2 (void) +{ + int status = 0; + + char *s = octave_string_variable ("PS2"); + if (s != (char *) NULL) + { + delete [] user_pref.ps2; + user_pref.ps2 = s; + } + else + { + warning ("invalid value specified for PS2"); + status = -1; + } + + return status; +} + +int +sv_pwd (void) +{ + int status = 0; + + char *s = octave_string_variable ("PWD"); + if (s != (char *) NULL) + { + delete [] user_pref.pwd; + user_pref.pwd = s; + } + else + { + warning ("invalid value specified for PWD"); + status = -1; + } + + return status; +} + +int +sv_gnuplot_binary (void) +{ + int status = 0; + + char *s = octave_string_variable ("gnuplot_binary"); + if (s != (char *) NULL) + { + delete [] user_pref.gnuplot_binary; + user_pref.gnuplot_binary = s; + } + else + { + warning ("invalid value specified for gnuplot_binary"); + status = -1; + } + + return status; +} + +int +sv_pager_binary (void) +{ + int status = 0; + + char *s = octave_string_variable ("PAGER"); + if (s != (char *) NULL) + { + delete [] user_pref.pager_binary; + user_pref.pager_binary = s; + } + else + { + warning ("invalid value specified for PAGER"); + status = -1; + } + + return status; +} + +/* +;;; Local Variables: *** +;;; mode: C++ *** +;;; page-delimiter: "^/\\*" *** +;;; End: *** +*/
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/user-prefs.h Sun Aug 08 01:13:40 1993 +0000 @@ -0,0 +1,100 @@ +// user-prefs.h -*- C++ -*- +/* + +Copyright (C) 1992, 1993 John W. Eaton + +This file is part of Octave. + +Octave is free software; you can redistribute it and/or modify it +under the terms of the GNU General Public License as published by the +Free Software Foundation; either version 2, or (at your option) any +later version. + +Octave is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +for more details. + +You should have received a copy of the GNU General Public License +along with Octave; see the file COPYING. If not, write to the Free +Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. + +*/ + +#if !defined (_user_prefs_h) +#define _user_prefs_h 1 + +#ifdef __GNUG__ +#pragma interface +#endif + +struct user_preferences +{ + int do_fortran_indexing; + int empty_list_elements_ok; + int implicit_str_to_num_ok; + int ok_to_lose_imaginary_part; + int prefer_column_vectors; + int prefer_zero_one_indexing; + int print_answer_id_name; + int propagate_empty_matrices; + int print_empty_dimensions; + int resize_on_range_error; + int return_last_computed_value; + int silent_functions; + int split_long_rows; + int treat_neg_dim_as_zero; + int warn_comma_in_global_decl; + int warn_divide_by_zero; + int warn_assign_as_truth_value; + int page_screen_output; + int output_max_field_width; + int output_precision; + + char *loadpath; + char *ps1; + char *ps2; + char *pwd; + char *gnuplot_binary; + char *pager_binary; +}; + +extern user_preferences user_pref; + +extern int do_fortran_indexing (void); +extern int empty_list_elements_ok (void); +extern int implicit_str_to_num_ok (void); +extern int ok_to_lose_imaginary_part (void); +extern int prefer_column_vectors (void); +extern int prefer_zero_one_indexing (void); +extern int print_answer_id_name (void); +extern int propagate_empty_matrices (void); +extern int print_empty_dimensions (void); +extern int resize_on_range_error (void); +extern int return_last_computed_value (void); +extern int silent_functions (void); +extern int split_long_rows (void); +extern int treat_neg_dim_as_zero (void); +extern int warn_comma_in_global_decl (void); +extern int warn_divide_by_zero (void); +extern int warn_assign_as_truth_value (void); +extern int page_screen_output (void); + +extern int set_output_max_field_width (void); +extern int set_output_precision (void); + +extern int sv_loadpath (void); +extern int sv_pager_binary (void); +extern int sv_ps1 (void); +extern int sv_ps2 (void); +extern int sv_pwd (void); +extern int sv_gnuplot_binary (void); + +#endif + +/* +;;; Local Variables: *** +;;; mode: C++ *** +;;; page-delimiter: "^/\\*" *** +;;; End: *** +*/
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/utils.cc Sun Aug 08 01:13:40 1993 +0000 @@ -0,0 +1,1274 @@ +// utils.cc -*- C++ -*- +/* + +Copyright (C) 1992, 1993 John W. Eaton + +This file is part of Octave. + +Octave is free software; you can redistribute it and/or modify it +under the terms of the GNU General Public License as published by the +Free Software Foundation; either version 2, or (at your option) any +later version. + +Octave is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +for more details. + +You should have received a copy of the GNU General Public License +along with Octave; see the file COPYING. If not, write to the Free +Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. + +*/ + +/* + +The 11 functions listed below were adapted from a similar functions +from GNU Bash, the Bourne Again SHell, copyright (C) 1987, 1989, 1991 +Free Software Foundation, Inc. + + polite_directory_format absolute_pathname + absolute_program base_pathname + read_octal sub_append_string + decode_prompt_string pathname_backup + make_absolute get_working_directory + change_to_directory + +*/ + +#ifdef __GNUG__ +#pragma implementation +#endif + +#include <sys/types.h> +#ifdef HAVE_UNISTD_H +#include <unistd.h> +#endif +#include <sys/param.h> +#include <setjmp.h> +#include <string.h> +#include <stdlib.h> +#include <stdio.h> +#include <time.h> +#include <math.h> +#include <limits.h> +#include <iostream.h> +#include <strstream.h> +#include <fstream.h> +#include <dirent.h> + +#define NLENGTH(dirent) (strlen((dirent)->d_name)) + +#ifdef HAVE_TERMIO_H +#include <termio.h> +#else +#ifdef HAVE_SGTTY_H +#include <sgtty.h> +#else +LOSE! LOSE! +#endif +#endif + +extern "C" +{ + extern int ioctl (int, int, ...); + char *tilde_expand (char *s); /* From readline's tilde.c */ +} + +#include "SLStack.h" + +#include "statdefs.h" +#include "procstream.h" +#include "user-prefs.h" +#include "variables.h" +#include "error.h" +#include "utils.h" +#include "octave.h" +#include "mappers.h" +#include "version.h" +#include "tree-const.h" +#include "unwind-prot.h" +#include "octave-hist.h" + +// Top level context (?) +extern jmp_buf toplevel; + +// Pipe to gnuplot. +static oprocstream plot_stream; + +// Non-zero means follow symbolic links that point to directories just +// as if they are real directories. +static int follow_symbolic_links = 1; + +#ifndef MAXPATHLEN +#define MAXPATHLEN 1024 +#endif + +// The size that strings change by. +#ifndef DEFAULT_ARRAY_SIZE +#define DEFAULT_ARRAY_SIZE 512 +#endif + +// The growth rate for the prompt string. +#ifndef PROMPT_GROWTH +#define PROMPT_GROWTH 50 +#endif + +#ifndef MAX +#define MAX(a,b) ((a) > (b) ? (a) : (b)) +#endif + +#ifndef MIN +#define MIN(a,b) ((a) < (b) ? (a) : (b)) +#endif + +// Where to find the site-wide configuration file +#ifndef OCTAVE_HOME +#define OCTAVE_HOME "/usr/local" +#endif + +// Temp storage for a path. +static char tdir[MAXPATHLEN]; + +// List of files to delete when we exit or crash. +static SLStack <char *> tmp_files; + +/* + * Save a string. + */ +char * +strsave (const char *s) +{ + if (s == (char *) NULL) + return (char *) NULL; + + int len = strlen (s); + char *tmp = new char [len+1]; + tmp = strcpy (tmp, s); + return tmp; +} + +/* + * Concatenate two strings. + */ +char * +strconcat (const char *s, const char *t) +{ + int len = strlen (s) + strlen (t); + char *tmp = new char [len+1]; + strcpy (tmp, s); + return strcat (tmp, t); +} + +/* + * Throw away input until a given character is read. + */ +void +discard_until (istream& stream, char character) +{ + int c; + for (;;) + { + stream >> c; + if (c == EOF || c == character) + break; + } + if (c != EOF) + stream.putback ((char) c); +} + +void +check_dimensions (int& nr, int& nc, char *warnfor) +{ + if (nr < 0 || nc < 0) + { + if (user_pref.treat_neg_dim_as_zero) + nr = nc = 0; + else + { + message (warnfor, "can't create a matrix with negative dimensions"); + jump_to_top_level (); + } + } +} + +/* + * Set terminal in raw mode. From less-177. + * + * Change terminal to "raw mode", or restore to "normal" mode. + * "Raw mode" means + * 1. An outstanding read will complete on receipt of a single keystroke. + * 2. Input is not echoed. + * 3. On output, \n is mapped to \r\n. + * 4. \t is NOT expanded into spaces. + * 5. Signal-causing characters such as ctrl-C (interrupt), + * etc. are NOT disabled. + * It doesn't matter whether an input \n is mapped to \r, or vice versa. + */ +void +raw_mode (int on) +{ + static int curr_on = 0; + +// HACK! HACK! + + int tty_fd = 1; + + if (on == curr_on) + return; + +#ifdef HAVE_TERMIO_H + { + struct termio s; + static struct termio save_term; + + if (on) + { +// Get terminal modes. + + ioctl(tty_fd, TCGETA, &s); + +// Save modes and set certain variables dependent on modes. + + save_term = s; +// ospeed = s.c_cflag & CBAUD; +// erase_char = s.c_cc[VERASE]; +// kill_char = s.c_cc[VKILL]; + +// Set the modes to the way we want them. + + s.c_lflag &= ~(ICANON|ECHO|ECHOE|ECHOK|ECHONL); + s.c_oflag |= (OPOST|ONLCR|TAB3); + s.c_oflag &= ~(OCRNL|ONOCR|ONLRET); + s.c_cc[VMIN] = 1; + s.c_cc[VTIME] = 0; + } + else + { +// Restore saved modes. + s = save_term; + } + ioctl(tty_fd, TCSETAW, &s); + } +#else +#ifdef HAVE_SGTTY_H + { + struct sgttyb s; + static struct sgttyb save_term; + + if (on) + { +// Get terminal modes. + + ioctl(tty_fd, TIOCGETP, &s); + +// Save modes and set certain variables dependent on modes. + + save_term = s; +// ospeed = s.sg_ospeed; +// erase_char = s.sg_erase; +// kill_char = s.sg_kill; + +// Set the modes to the way we want them. + + s.sg_flags |= CBREAK; + s.sg_flags &= ~(ECHO|XTABS); + } + else + { +// Restore saved modes. + s = save_term; + } + ioctl(tty_fd, TIOCSETN, &s); + } +#else +LOSE! LOSE! +#endif +#endif + + curr_on = on; +} + +/* + * Read one character from the terminal. + */ +int +kbhit (void) +{ + int c; + raw_mode (1); + c = cin.get (); + raw_mode (0); + return c; +} + +char ** +pathstring_to_vector (char *pathstring) +{ + static char **path = (char **) NULL; + + if (pathstring != (char *) NULL) + { + int nelem = 0; + pathstring = strsave (pathstring); + if (*pathstring != '\0') + { + nelem++; + char *ptr = pathstring; + while (*ptr != '\0') + { + if (*ptr == ':') + nelem++; + ptr++; + } + } + + delete [] path; + path = new char * [nelem+1]; + path[nelem] = (char *) NULL; + + int i = 0; + char *ptr = pathstring; + while (i < nelem) + { + char *end = strchr (ptr, ':'); + if (end != (char *) NULL) + *end = '\0'; + char *result = tilde_expand (ptr); + path[i] = strsave (result); + free (result); + ptr = end + 1; + i++; + } + + delete [] pathstring; + } + + return path; +} + +static char * +octave_home (void) +{ + static char *home = (char *) NULL; + delete [] home; + char *oh = getenv ("OCTAVE_HOME"); + if (oh != (char *) NULL) + home = strsave (oh); + else + home = strsave (OCTAVE_HOME); + return home; +} + +static char * +octave_lib_dir (void) +{ + static char *ol = (char *) NULL; + delete [] ol; + char *oh = octave_home (); + char *tmp = strconcat (oh, "/lib/octave/"); + ol = strconcat (tmp, version_string); + return ol; +} + +char * +default_path (void) +{ + static char *pathstring = (char *) NULL; + delete [] pathstring; + char *oct_path = getenv ("OCTAVE_PATH"); + if (oct_path != (char *) NULL) + pathstring = strsave (oct_path); + else + { + char *libdir = octave_lib_dir (); + pathstring = strconcat (".:", libdir); + } + return pathstring; +} + +char * +get_site_defaults (void) +{ + static char *sd = (char *) NULL; + delete [] sd; + char *libdir = octave_lib_dir (); + sd = strconcat (libdir, "/octaverc"); + return sd; +} + +char * +default_pager (void) +{ + static char *pager_binary = (char *) NULL; + delete [] pager_binary; + char *pgr = getenv ("PAGER"); + if (pgr != (char *) NULL) + pager_binary = strsave (pgr); + else +#ifdef DEFAULT_PAGER + pager_binary = strsave (DEFAULT_PAGER); +#else + pager_binary = strsave (""); +#endif + + return pager_binary; +} + +/* + * See if the given file is in the path. + */ +char * +file_in_path (char *name, char *suffix) +{ + char *nm = strconcat ("/", name); + char *tmp = nm; + if (suffix != (char *) NULL) + { + nm = strconcat (tmp, suffix); + delete [] tmp; + } + + if (!the_current_working_directory) + get_working_directory ("file_in_path"); + + char **path = pathstring_to_vector (user_pref.loadpath); + + char **ptr = path; + if (ptr != (char **) NULL) + { + while (*ptr != (char *) NULL) + { + char *tmp_p = strconcat (*ptr, nm); + char *p = make_absolute (tmp_p, the_current_working_directory); + delete [] tmp_p; + ifstream in_file (p); + if (in_file) + { + in_file.close (); + delete [] nm; + return p; + } + delete [] p; + ptr++; + } + } + + delete [] nm; + return (char *) NULL; +} + +/* + * See if there is an M-file in the path. If so, return the full path + * to the file. + */ +char * +m_file_in_path (char *name) +{ + return file_in_path (name, ".m"); +} + +/* + * Return a pretty pathname. If the first part of the pathname is the + * same as $HOME, then replace that with `~'. + */ +char * +polite_directory_format (char *name) +{ + int l = home_directory ? strlen (home_directory) : 0; + + if (l > 1 && strncmp (home_directory, name, l) == 0 + && (!name[l] || name[l] == '/')) + { + strcpy (tdir + 1, name + l); + tdir[0] = '~'; + return (tdir); + } + else + return name; +} + +/* + * Return 1 if STRING contains an absolute pathname, else 0. + */ +int +absolute_pathname (char *string) +{ + if (!string || !*string) + return 0; + + if (*string == '/') + return 1; + + if (*string++ == '.') + { + if ((!*string) || *string == '/') + return 1; + + if (*string++ == '.') + if (!*string || *string == '/') + return 1; + } + return 0; +} + +/* + * Return 1 if STRING is an absolute program name; it is absolute if + * it contains any slashes. This is used to decide whether or not to + * look up through $PATH. + */ +int +absolute_program (char *string) +{ + return (strchr (string, '/') != (char *)NULL); +} + +/* + * Return the `basename' of the pathname in STRING (the stuff after + * the last '/'). If STRING is not a full pathname, simply return it. + */ +char * +base_pathname (char *string) +{ + char *p = strrchr (string, '/'); + + if (!absolute_pathname (string)) + return (string); + + if (p) + return (++p); + else + return (string); +} + +/* + * Return the octal number parsed from STRING, or -1 to indicate that + * the string contained a bad number. + */ +int +read_octal (char *string) +{ + int result = 0; + int digits = 0; + + while (*string && *string >= '0' && *string < '8') + { + digits++; + result = (result * 8) + *string++ - '0'; + } + + if (!digits || result > 0777 || *string) + result = -1; + + return result; +} + +/* + * Append SOURCE to TARGET at INDEX. SIZE is the current amount of + * space allocated to TARGET. SOURCE can be NULL, in which case + * nothing happens. Gets rid of SOURCE by free ()ing it. Returns + * TARGET in case the location has changed. + */ +char * +sub_append_string (char *source, char *target, int *index, int *size) +{ + if (source) + { + while ((int)strlen (source) >= (int)(*size - *index)) + { + char *tmp = new char [*size += DEFAULT_ARRAY_SIZE]; + strcpy (tmp, target); + delete [] target; + target = tmp; + } + + strcat (target, source); + *index += strlen (source); + + delete [] source; + } + return target; +} + +/* + * Return a string which will be printed as a prompt. The string may + * contain special characters which are decoded as follows: + * + * \t the time + * \d the date + * \n CRLF + * \s the name of the shell (program) + * \w the current working directory + * \W the last element of PWD + * \u your username + * \h the hostname + * \# the command number of this command + * \! the history number of this command + * \$ a $ or a # if you are root + * \<octal> character code in octal + * \\ a backslash + */ +char * +decode_prompt_string (char *string) +{ + int result_size = PROMPT_GROWTH; + int result_index = 0; + char *result = new char [PROMPT_GROWTH]; + int c; + char *temp = (char *)NULL; + + result[0] = 0; + while (c = *string++) + { + if (c == '\\') + { + c = *string; + + switch (c) + { + case '0': + case '1': + case '2': + case '3': + case '4': + case '5': + case '6': + case '7': + { + char octal_string[4]; + int n; + + strncpy (octal_string, string, 3); + octal_string[3] = '\0'; + + n = read_octal (octal_string); + + temp = strsave ("\\"); + if (n != -1) + { + string += 3; + temp[0] = n; + } + + c = 0; + goto add_string; + } + + case 't': + case 'd': + /* Make the current time/date into a string. */ + { + long the_time = time (0); + char *ttemp = ctime (&the_time); + temp = strsave (ttemp); + + if (c == 't') + { + strcpy (temp, temp + 11); + temp[8] = '\0'; + } + else + temp[10] = '\0'; + + goto add_string; + } + + case 'n': + if (!no_line_editing) + temp = strsave ("\r\n"); + else + temp = strsave ("\n"); + goto add_string; + + case 's': + { + temp = base_pathname (prog_name); + temp = strsave (temp); + goto add_string; + } + + case 'w': + case 'W': + { + char t_string[MAXPATHLEN]; +#define EFFICIENT +#ifdef EFFICIENT + +// Use the value of PWD because it is much more effecient. + + temp = user_pref.pwd; + + if (!temp) + getcwd (t_string, MAXPATHLEN); + else + strcpy (t_string, temp); +#else + getcwd (t_string, MAXPATHLEN); +#endif /* EFFICIENT */ + + if (c == 'W') + { + char *dir = strrchr (t_string, '/'); + if (dir && dir != t_string) + strcpy (t_string, dir + 1); + temp = strsave (t_string); + } + else + temp = strsave (polite_directory_format (t_string)); + goto add_string; + } + + case 'u': + { + temp = strsave (user_name); + + goto add_string; + } + + case 'h': + { + char *t_string; + + temp = strsave (host_name); + if (t_string = strchr (temp, '.')) + *t_string = '\0'; + + goto add_string; + } + + case '#': + { + char number_buffer[20]; + sprintf (number_buffer, "%d", current_command_number); + temp = strsave (number_buffer); + goto add_string; + } + + case '!': + { + char number_buffer[20]; + int num = current_history_number (); + if (num > 0) + sprintf (number_buffer, "%d", num); + else + strcpy (number_buffer, "!"); + temp = strsave (number_buffer); + goto add_string; + } + + case '$': + temp = strsave (geteuid () == 0 ? "#" : "$"); + goto add_string; + + case '\\': + temp = strsave ("\\"); + goto add_string; + + default: + temp = strsave ("\\ "); + temp[1] = c; + + add_string: + if (c) + string++; + result = + (char *)sub_append_string (temp, result, + &result_index, &result_size); + temp = (char *)NULL; /* Free ()'ed in sub_append_string (). */ + result[result_index] = '\0'; + break; + } + } + else + { + while (3 + result_index > result_size) + { + char *tmp = new char [result_size += PROMPT_GROWTH]; + strcpy (tmp, result); + delete [] result; + result = tmp; + } + result[result_index++] = c; + result[result_index] = '\0'; + } + } + +#if 0 + /* I don't really think that this is a good idea. Do you? */ + if (!find_variable ("NO_PROMPT_VARS")) + { + WORD_LIST *expand_string (), *list; + char *string_list (); + + list = expand_string (result, 1); + free (result); + result = string_list (list); + dispose_words (list); + } +#endif + + return result; +} + +/* + * Remove the last N directories from PATH. Do not PATH blank. + * PATH must contain enoung space for MAXPATHLEN characters. + */ +void +pathname_backup (char *path, int n) +{ + register char *p; + + if (!*path) + return; + + p = path + (strlen (path) - 1); + + while (n--) + { + while (*p == '/' && p != path) + p--; + + while (*p != '/' && p != path) + p--; + + *++p = '\0'; + } +} + +/* + * Turn STRING (a pathname) into an absolute pathname, assuming that + * DOT_PATH contains the symbolic location of '.'. This always + * returns a new string, even if STRING was an absolute pathname to + * begin with. + */ +char * +make_absolute (char *string, char *dot_path) +{ + static char current_path[MAXPATHLEN]; + register char *cp; + + if (!dot_path || *string == '/') + return strsave (string); + + strcpy (current_path, dot_path); + + if (!current_path[0]) + strcpy (current_path, "./"); + + cp = current_path + (strlen (current_path) - 1); + + if (*cp++ != '/') + *cp++ = '/'; + + *cp = '\0'; + + while (*string) + { + if (*string == '.') + { + if (!string[1]) + return strsave (current_path); + + if (string[1] == '/') + { + string += 2; + continue; + } + + if (string[1] == '.' && (string[2] == '/' || !string[2])) + { + string += 2; + + if (*string) + string++; + + pathname_backup (current_path, 1); + cp = current_path + strlen (current_path); + continue; + } + } + + while (*string && *string != '/') + *cp++ = *string++; + + if (*string) + *cp++ = *string++; + + *cp = '\0'; + } + return strsave (current_path); +} + +/* + * Return a consed string which is the current working directory. + * FOR_WHOM is the name of the caller for error printing. + */ +char * +get_working_directory (char *for_whom) +{ + if (!follow_symbolic_links) + { + if (the_current_working_directory) + delete [] the_current_working_directory; + + the_current_working_directory = (char *)NULL; + } + + if (!the_current_working_directory) + { + char *directory; + + the_current_working_directory = new char [MAXPATHLEN]; + directory = getcwd (the_current_working_directory, MAXPATHLEN); + if (!directory) + { + message (for_whom, the_current_working_directory); + delete [] the_current_working_directory; + the_current_working_directory = (char *)NULL; + return (char *)NULL; + } + } + + return the_current_working_directory; +} + +/* + * Do the work of changing to the directory NEWDIR. Handle symbolic + * link following, etc. + */ +int +change_to_directory (char *newdir) +{ + char *t; + + if (follow_symbolic_links) + { + if (!the_current_working_directory) + get_working_directory ("cd_links"); + + if (the_current_working_directory) + t = make_absolute (newdir, the_current_working_directory); + else + t = strsave (newdir); + + /* Get rid of trailing `/'. */ + { + register int len_t = strlen (t); + if (len_t > 1) + { + --len_t; + if (t[len_t] == '/') + t[len_t] = '\0'; + } + } + + if (chdir (t) < 0) + { + delete [] t; + return 0; + } + + if (the_current_working_directory) + strcpy (the_current_working_directory, t); + + delete [] t; + return 1; + } + else + { + if (chdir (newdir) < 0) + return 0; + else + return 1; + } +} + +/* + * Has file `A' been modified after time `T'? + * + * case: + * + * a newer than t returns 1 + * a older than t returns 0 + * stat on a fails returns -1 + */ +int +is_newer (char *fa, time_t t) +{ + struct stat fa_sb; + register int fa_stat; + register int status = 0; + + fa_stat = stat (fa, &fa_sb); + if (fa_stat != 0) + status = -1; + + if (status != 0) + return status; + + return (fa_sb.st_mtime > t); +} + +/* + * Return to the main command loop in octave.cc. + */ +volatile void +jump_to_top_level (void) +{ + run_all_unwind_protects (); + + longjmp (toplevel, 1); +} + +/* + * Gag. + */ +char * +s_plural (int i) +{ + static char *empty = ""; + static char *s = "s"; + return i == 1 ? empty : s; +} + +char * +es_plural (int i) +{ + static char *empty = ""; + static char *es = "es"; + return i == 1 ? es : empty; +} + +char * +save_in_tmp_file (tree_constant& t, int ndim = 2, int parametric = 0) +{ + char *name = strsave (tmpnam ((char *) NULL)); + if (name != (char *) NULL) + { + ofstream file (name); + if (file) + { + switch (ndim) + { + case 2: + t.save (file); + break; + case 3: + t.save_three_d (file, parametric); + break; + default: + panic_impossible (); + break; + } + } + else + { + error ("couldn't open temporary output file `%s'", name); + delete [] name; + name = (char *) NULL; + } + } + return name; +} + +void +mark_for_deletion (const char *filename) +{ + char *tmp = strsave (filename); + tmp_files.push (tmp); +} + +void +cleanup_tmp_files (void) +{ + while (! tmp_files.empty ()) + { + char *filename = tmp_files.pop (); + unlink (filename); + delete [] filename; + } +} + +int +send_to_plot_stream (const char *cmd) +{ +// From sighandlers.cc: + extern int pipe_handler_error_count; + + static int initialized = 0; + + if (! plot_stream.is_open ()) + { + char *plot_prog = user_pref.gnuplot_binary; + if (plot_prog != (char *) NULL) + { + plot_stream.open (plot_prog); + if (! plot_stream.is_open ()) + { + warning ("plot: unable to open pipe to `%s'", + plot_prog); + + if (strcmp (plot_prog, "gnuplot") != 0) + { + message ("plot", "trying again with `gnuplot'"); + goto last_chance; + } + } + } + else + { + last_chance: + + plot_stream.open ("gnuplot"); + + if (! plot_stream.is_open ()) + { + error ("plot: unable to open pipe to `%s'", plot_prog); + return -1; + } + } + } + + if (! initialized) + { + initialized = 1; + plot_stream << "set data style lines\n"; + } + + plot_stream << cmd; + plot_stream.flush (); + pipe_handler_error_count = 0; + + return 0; +} + +void +close_plot_stream (void) +{ + if (plot_stream.is_open ()) + plot_stream.close (); +} + +int +almost_match (char *std, char *s, int min_match_len = 1) +{ + int stdlen = strlen (std); + int slen = strlen (s); + + return (slen <= stdlen + && slen >= min_match_len + && strncmp (std, s, slen) == 0); +} + +char ** +get_m_file_names (int& num, char *dir, int no_suffix) +{ + static int num_max = 256; + char **retval = new char * [num_max]; + int i = 0; + + DIR *dirp = opendir (dir); + if (dirp != (DIR *) NULL) + { + struct dirent *entry; + while ((entry = readdir (dirp)) != (struct dirent *) NULL) + { + int len = NLENGTH (entry); + if (len > 2 + && entry->d_name[len-2] == '.' + && entry->d_name[len-1] == 'm') + { + retval[i] = strsave (entry->d_name); + if (no_suffix) + retval[i][len-2] = '\0'; + + i++; + + if (i == num_max - 1) + { + num_max += 256; + char **tmp = new char * [num_max]; + for (int j = 0; j < i; j++) + tmp[j] = retval[j]; + + retval = tmp; + } + } + } + free (dirp); + } + + retval[i] = (char *) NULL; + num = i; + + return retval; +} + +char ** +get_m_file_names (int& num, int no_suffix) +{ + static int num_max = 1024; + char **retval = new char * [num_max]; + int i = 0; + + char **path = pathstring_to_vector (user_pref.loadpath); + + char **ptr = path; + if (ptr != (char **) NULL) + { + while (*ptr != (char *) NULL) + { + int tmp_num; + char **names = get_m_file_names (tmp_num, *ptr, no_suffix); + + if (i + tmp_num >= num_max - 1) + { + num_max += 1024; + char **tmp = new char * [num_max]; + for (int j = 0; j < i; j++) + tmp[j] = retval[j]; + + retval = tmp; + } + + int k = 0; + while (k < tmp_num) + retval[i++] = names[k++]; + + ptr++; + } + } + + retval[i] = (char *) NULL; + num = i; + + return retval; +} + +int +NINT (double x) +{ + if (x > INT_MAX) + return INT_MAX; + else if (x < INT_MIN) + return INT_MIN; + else + return (x > 0) ? ((int) (x + 0.5)) : ((int) (x - 0.5)); +} + +double +D_NINT (double x) +{ + if (xisinf (x) || xisnan (x)) + return x; + else + return floor (x + 0.5); +} + +/* +;;; Local Variables: *** +;;; mode: C++ *** +;;; page-delimiter: "^/\\*" *** +;;; End: *** +*/
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/utils.h Sun Aug 08 01:13:40 1993 +0000 @@ -0,0 +1,82 @@ +// utils.h -*- C++ -*- +/* + +Copyright (C) 1992, 1993 John W. Eaton + +This file is part of Octave. + +Octave is free software; you can redistribute it and/or modify it +under the terms of the GNU General Public License as published by the +Free Software Foundation; either version 2, or (at your option) any +later version. + +Octave is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +for more details. + +You should have received a copy of the GNU General Public License +along with Octave; see the file COPYING. If not, write to the Free +Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. + +*/ + +#if !defined (_utils_h) +#define _utils_h 1 + +#ifdef __GNUG__ +#pragma interface +#endif + +#include <time.h> + +class istream; +class ostrstream; +class tree_constant; + +extern char *strsave (const char *); +extern char *strconcat (const char *, const char *); +extern void discard_until (istream&, char); +extern void check_dimensions (int& nr, int& nc, char *warnfor); +extern void raw_mode (int); +extern int kbhit (void); +extern char **pathstring_to_vector (char *); +extern char *default_path (void); +extern char *get_site_defaults (void); +extern char *default_pager (void); +extern char *file_in_path (char *, char *); +extern char *m_file_in_path (char *); +extern char *polite_directory_format (char *); +extern int absolute_pathname (char *); +extern int absolute_program (char *); +extern char *base_pathname (char *); +extern int read_octal (char *); +extern char *sub_append_string (char *, char *, int *, int *); +extern char *decode_prompt_string (char *); +extern void pathname_backup (char *, int); +extern char *make_absolute (char *, char *); +extern char *get_working_directory (char *); +extern int change_to_directory (char *); +extern int is_newer (char *, time_t); +extern volatile void jump_to_top_level (void); +extern char *s_plural (int); +extern char *es_plural (int); +extern char *save_in_tmp_file (tree_constant& t, int nd = 2, int para = 0); +extern void mark_for_deletion (const char *); +extern void cleanup_tmp_files (void); +extern int send_to_plot_stream (const char *cmd); +extern void close_plot_stream (void); +extern int almost_match (char *std, char *s, int min_match_len = 1); +extern char **get_m_file_names (int& mfl_len, char *dir, int no_suffix); +extern char **get_m_file_names (int& mfl_len, int no_suffix); +extern int NINT (double x); +extern double D_NINT (double x); + +#endif + +/* +;;; Local Variables: *** +;;; mode: C++ *** +;;; page-delimiter: "^/\\*" *** +;;; End: *** +*/
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/variables.cc Sun Aug 08 01:13:40 1993 +0000 @@ -0,0 +1,514 @@ +// variables.cc -*- C++ -*- +/* + +Copyright (C) 1992, 1993 John W. Eaton + +This file is part of Octave. + +Octave is free software; you can redistribute it and/or modify it +under the terms of the GNU General Public License as published by the +Free Software Foundation; either version 2, or (at your option) any +later version. + +Octave is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +for more details. + +You should have received a copy of the GNU General Public License +along with Octave; see the file COPYING. If not, write to the Free +Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. + +*/ + +#ifdef __GNUG__ +#pragma implementation +#endif + +#include <sys/types.h> +#ifdef HAVE_UNISTD_H +#include <unistd.h> +#endif +#include <ctype.h> +#include <iostream.h> + +#include "statdefs.h" +#include "tree-const.h" +#include "variables.h" +#include "symtab.h" +#include "error.h" +#include "utils.h" +#include "tree.h" + +// Symbol table for symbols at the top level. +symbol_table *top_level_sym_tab; + +// Symbol table for the current scope. +symbol_table *curr_sym_tab; + +// Symbol table for global symbols. +symbol_table *global_sym_tab; + +/* + * Is there a corresponding M-file that is newer than the symbol + * definition? + */ +int +symbol_out_of_date (symbol_record *sr) +{ + int status = 0; + if (sr != (symbol_record *) NULL) + { + tree *ans = sr->def (); + if (ans != NULL_TREE) + { + char *mf = ans->m_file_name (); + if (mf != (char *) NULL) + { + time_t tp = ans->time_parsed (); + status = is_newer (mf, tp); + } + } + } + return status; +} + +/* + * Force a symbol into the global symbol table. + */ +symbol_record * +force_global (char *name) +{ + symbol_record *retval = (symbol_record *) NULL; + + if (valid_identifier (name)) + { + symbol_record *sr; + sr = curr_sym_tab->lookup (name, 0, 0); + if (sr == (symbol_record *) NULL) + { + retval = global_sym_tab->lookup (name, 1, 0); + } + else if (sr->is_formal_parameter ()) + { + error ("formal parameter `%s' can't be made global", name); + } + else + { + retval = global_sym_tab->lookup (name, 1, 0); + retval->alias (sr); + curr_sym_tab->clear (name); + } + } + else + warning ("`%s' is invalid as an identifier", name); + + return retval; +} + +int +bind_variable (char *varname, tree_constant *val) +{ +// Look for the symbol in the current symbol table. If it's there, +// great. If not, don't insert it, but look for it in the global +// symbol table. If it's there, great. If not, insert it in the +// original current symbol table. + + symbol_record *sr; + sr = curr_sym_tab->lookup (varname, 0, 0); + if (sr == (symbol_record *) NULL) + { + sr = global_sym_tab->lookup (varname, 0, 0); + if (sr == (symbol_record *) NULL) + { + sr = curr_sym_tab->lookup (varname, 1); + } + } + + if (sr != (symbol_record *) NULL) + { + sr->define (val); + return 0; + } + else + return 1; +} + +int +bind_protected_variable (char *varname, tree_constant *val) +{ +// Look for the symbol in the current symbol table. If it's there, +// great. If not, don't insert it, but look for it in the global +// symbol table. If it's there, great. If not, insert it in the +// original current symbol table. + + symbol_record *sr; + sr = curr_sym_tab->lookup (varname, 0, 0); + if (sr == (symbol_record *) NULL) + { + sr = global_sym_tab->lookup (varname, 0, 0); + if (sr == (symbol_record *) NULL) + { + sr = curr_sym_tab->lookup (varname, 1); + } + } + + if (sr != (symbol_record *) NULL) + { + sr->unprotect (); + sr->define (val); + sr->protect (); + return 0; + } + else + return 1; +} + +/* + * Look for name first in current then in global symbol tables. If + * name is found and it refers to a string, return a new string + * containing its value. Otherwise, return NULL. + */ +char * +octave_string_variable (char *name) +{ + char *retval = (char *) NULL; + symbol_record *sr; + sr = curr_sym_tab->lookup (name, 0, 0); + if (sr == (symbol_record *) NULL) + { + sr = global_sym_tab->lookup (name, 0, 0); + if (sr == (symbol_record *) NULL) + return retval; + } + + tree *defn = sr->def (); + if (defn != NULL_TREE) + { + tree_constant val = defn->eval (0); + if (val.is_string_type ()) + { + char *s = val.string_value (); + if (s != (char *) NULL) + retval = strsave (s); + } + } + + return retval; +} + +/* + * Look for name first in current then in global symbol tables. If + * name is found and it refers to a real scalar, place the value in d + * and return 0. Otherwise, return -1. + */ +int +octave_real_scalar_variable (char *name, double& d) +{ + int status = -1; + symbol_record *sr; + sr = curr_sym_tab->lookup (name, 0, 0); + if (sr == (symbol_record *) NULL) + { + sr = global_sym_tab->lookup (name, 0, 0); + if (sr == (symbol_record *) NULL) + return status; + } + + tree *defn = sr->def (); + if (defn != NULL_TREE) + { + tree_constant val = defn->eval (0); + if (val.const_type () == tree_constant_rep::scalar_constant) + { + d = val.double_value (); + status = 0; + } + } + + return status; +} + +/* + * Extract a keyword and its value from a file. Input should look + * something like: + * + * #[ \t]*keyword[ \t]*:[ \t]*string-value\n + */ +int +extract_keyword (istream& is, char *keyword, char *value) +{ + char *ptr = value; + + int status = 0; + + char c; + while (is.get (c)) + { + if (c == '#') + { + while (is.get (c) && (c == ' ' || c == '\t' || c == '#')) + ; // Skip whitespace and comment characters. + + if (isalpha (c)) + *ptr++ = c; + + while (is.get (c) && isalpha (c)) + *ptr++ = c; + + if (strncmp (value, keyword, strlen (keyword)) == 0) + { + ptr = value; + while (is.get (c) && (c == ' ' || c == '\t' || c == ':')) + ; // Skip whitespace and the colon. + + if (c != '\n') + { + *ptr++ = c; + while (is.get (c) && c != '\n') + *ptr++ = c; + } + *ptr = '\0'; + status = 1; + break; + } + } + } + return status; +} + +int +extract_keyword (istream& is, char *keyword, int& value) +{ + char buf [128]; + char *ptr = buf; + + int status = 0; + value = 0; + + char c; + while (is.get (c)) + { + if (c == '#') + { + while (is.get (c) && (c == ' ' || c == '\t' || c == '#')) + ; // Skip whitespace and comment characters. + + if (isalpha (c)) + *ptr++ = c; + + while (is.get (c) && isalpha (c)) + *ptr++ = c; + + if (strncmp (buf, keyword, strlen (keyword)) == 0) + { + ptr = buf; + while (is.get (c) && (c == ' ' || c == '\t' || c == ':')) + ; // Skip whitespace and the colon. + + is.putback (c); + if (c != '\n') + is >> value; + if (is) + status = 1; + while (is.get (c) && c != '\n') + ; // Skip to beginning of next line; + break; + } + } + } + return status; +} + +/* + * Skip trailing white space and + */ +void +skip_comments (istream& is) +{ + char c = '\0'; + while (is.get (c)) + { + if (c == ' ' || c == '\t' || c == '\n') + ; // Skip whitespace on way to beginning of next line. + else + break; + } + + for (;;) + { + if (is && c == '#') + while (is.get (c) && c != '\n') + ; // Skip to beginning of next line, ignoring everything. + else + break; + } +} + +/* + * Is `s' a valid identifier? + */ +int +valid_identifier (char *s) +{ + if (s == (char *) NULL || ! (isalnum (*s) || *s == '_')) + return 0; + + while (*++s != '\0') + if (! (isalnum (*s) || *s == '_')) + return 0; + + return 1; +} + +/* + * See if the identifier is in scope. + */ +int +identifier_exists (char *name) +{ + int status = 0; + + if (curr_sym_tab->lookup (name, 0, 0) != (symbol_record *) NULL + || global_sym_tab->lookup (name, 0, 0) != (symbol_record *) NULL) + status = 1; + else + { + char *path = m_file_in_path (name); + if (path != (char *) NULL) + { + delete [] path; + status = 2; + } + else + { + struct stat buf; + if (stat (name, &buf) == 0 && S_ISREG (buf.st_mode)) + status = 2; + } + + } + return status; +} + +/* + * Is this tree_constant a valid function? + */ +tree * +is_valid_function (tree_constant& arg, char *warn_for, int warn = 0) +{ + tree *ans = NULL_TREE; + + if (! arg.is_string_type ()) + { + if (warn) + message (warn_for, "expecting function name as argument"); + return ans; + } + + char *fcn_name = arg.string_value (); + symbol_record *sr = global_sym_tab->lookup (fcn_name, 0, 0); + + if (sr == (symbol_record *) NULL) + { + sr = global_sym_tab->lookup (fcn_name, 1, 0); + tree_identifier tmp (sr); + tmp.parse_m_file (0); + } + else if (symbol_out_of_date (sr)) + { + tree_identifier tmp (sr); + tmp.parse_m_file (0); + } + + ans = sr->def (); + if (ans == NULL_TREE || ! sr->is_function ()) + { + if (warn) + message (warn_for, "the symbol `%s' is not valid as a function", + fcn_name); + ans = NULL_TREE; + } + + return ans; +} + +/* + * Does this function take the right number of arguments? + */ +int +takes_correct_nargs (tree *fcn, int expected_nargin, char *warn_for, + int warn = 0) +{ + int nargs = fcn->max_expected_args () - 1; + int e_nargs = expected_nargin - 1; + if (nargs != e_nargs) + { + if (warn) + message (warn_for, "expecting function to take %d argument%c", + e_nargs, s_plural (e_nargs)); + return 0; + } + return 1; +} + +char ** +make_name_list (void) +{ + int key_len = 0; + int glb_len = 0; + int top_len = 0; + int lcl_len = 0; + int mfl_len = 0; + + char **key = (char **) NULL; + char **glb = (char **) NULL; + char **top = (char **) NULL; + char **lcl = (char **) NULL; + char **mfl = (char **) NULL; + + key = names (keyword_help (), key_len); + glb = global_sym_tab->list (glb_len); + top = top_level_sym_tab->list (top_len); + if (top_level_sym_tab != curr_sym_tab) + lcl = curr_sym_tab->list (lcl_len); + mfl = get_m_file_names (mfl_len, 1); + + int total_len = key_len + glb_len + top_len + lcl_len + mfl_len; + + char **list = new char * [total_len+1]; + + int j = 0; + int i = 0; + for (i = 0; i < key_len; i++) + list[j++] = key[i]; + + for (i = 0; i < glb_len; i++) + list[j++] = glb[i]; + + for (i = 0; i < top_len; i++) + list[j++] = top[i]; + + for (i = 0; i < lcl_len; i++) + list[j++] = lcl[i]; + + for (i = 0; i < mfl_len; i++) + list[j++] = mfl[i]; + + list[j] = (char *) NULL; + + delete [] key; + delete [] glb; + delete [] top; + delete [] lcl; + delete [] mfl; + + return list; +} + +/* +;;; Local Variables: *** +;;; mode: C++ *** +;;; page-delimiter: "^/\\*" *** +;;; End: *** +*/
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/variables.h Sun Aug 08 01:13:40 1993 +0000 @@ -0,0 +1,68 @@ +// variables.h -*- C++ -*- +/* + +Copyright (C) 1992, 1993 John W. Eaton + +This file is part of Octave. + +Octave is free software; you can redistribute it and/or modify it +under the terms of the GNU General Public License as published by the +Free Software Foundation; either version 2, or (at your option) any +later version. + +Octave is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +for more details. + +You should have received a copy of the GNU General Public License +along with Octave; see the file COPYING. If not, write to the Free +Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. + +*/ + +#if !defined (_variables_h) +#define _variables_h 1 + +#ifdef __GNUG__ +#pragma interface +#endif + +class istream; +class symbol_record; +class symbol_table; +class tree; +class tree_constant; + +extern int symbol_out_of_date (symbol_record *sr); +extern symbol_record *force_global (char *name); +extern int bind_variable (char *, tree_constant *); +extern int bind_protected_variable (char *, tree_constant *); +extern char *octave_string_variable (char *); +extern int octave_real_scalar_variable (char *, double&); +extern int extract_keyword (istream&, char *, char *); +extern int extract_keyword (istream&, char *, int&); +extern void skip_comments (istream&); +extern int valid_identifier (char *); +extern int identifier_exists (char *); +extern tree *is_valid_function (tree_constant&, char *, int warn = 0); +extern int takes_correct_nargs (tree *, int, char *, int warn = 0); +extern char **make_name_list (void); + +// Symbol table for symbols at the top level. +extern symbol_table *top_level_sym_tab; + +// Symbol table for the current scope. +extern symbol_table *curr_sym_tab; + +// Symbol table for global symbols. +extern symbol_table *global_sym_tab; + +#endif + +/* +;;; Local Variables: *** +;;; mode: C++ *** +;;; page-delimiter: "^/\\*" *** +;;; End: *** +*/
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/xdiv.cc Sun Aug 08 01:13:40 1993 +0000 @@ -0,0 +1,356 @@ +// xdiv.cc -*- C++ -*- +/* + +Copyright (C) 1992, 1993 John W. Eaton + +This file is part of Octave. + +Octave is free software; you can redistribute it and/or modify it +under the terms of the GNU General Public License as published by the +Free Software Foundation; either version 2, or (at your option) any +later version. + +Octave is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +for more details. + +You should have received a copy of the GNU General Public License +along with Octave; see the file COPYING. If not, write to the Free +Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. + +*/ + +#ifdef __GNUG__ +#pragma implementation +#endif + +#include <assert.h> +#include "error.h" +#include "xdiv.h" + +static inline int +result_ok (int info, double rcond, int warn = 1) +{ + assert (info != -1); + + if (info == -2) + { + error ("matrix singular to machine precision, rcond = %g", rcond); + return 0; + } + else + return 1; +} + +static inline int +mx_leftdiv_conform (int a_nr, int a_nc, int b_nr, int warn = 1) +{ + if (a_nr != b_nr) + { + error ("number of rows must be the same for left division"); + return 0; + } + + return 1; +} + +static inline int +mx_div_conform (int b_nr, int b_nc, int a_nc, int warn = 1) +{ + if (a_nc != b_nc) + { + error ("number of columns must be the same for right division"); + return 0; + } + + return 1; +} + +/* + * Right division functions. + * + * op2 / op1: m cm + * +-- +---+----+ + * matrix | 1 | 3 | + * +---+----+ + * complex_matrix | 2 | 4 | + * +---+----+ + */ + +/* 1 */ +tree_constant +xdiv (Matrix& a, Matrix& b) +{ + if (! mx_div_conform (b.rows (), b.columns (), a.columns ())) + return tree_constant (); + + Matrix atmp = a.transpose (); + Matrix btmp = b.transpose (); + + int info; + if (btmp.rows () == btmp.columns ()) + { + double rcond = 0.0; + Matrix result = btmp.solve (atmp, info, rcond); + if (result_ok (info, rcond)) + return tree_constant (result.transpose ()); + } + + int rank; + Matrix result = btmp.lssolve (atmp, info, rank); + + return tree_constant (result.transpose ()); +} + +/* 2 */ +tree_constant +xdiv (Matrix& a, ComplexMatrix& b) +{ + if (! mx_div_conform (b.rows (), b.columns (), a.columns ())) + return tree_constant (); + + Matrix atmp = a.transpose (); + ComplexMatrix btmp = b.hermitian (); + + int info; + if (btmp.rows () == btmp.columns ()) + { + double rcond = 0.0; + ComplexMatrix result = btmp.solve (atmp, info, rcond); + if (result_ok (info, rcond)) + return tree_constant (result.hermitian ()); + } + + int rank; + ComplexMatrix result = btmp.lssolve (atmp, info, rank); + + return tree_constant (result.hermitian ()); +} + +/* 3 */ +tree_constant +xdiv (ComplexMatrix& a, Matrix& b) +{ + if (! mx_div_conform (b.rows (), b.columns (), a.columns ())) + return tree_constant (); + + ComplexMatrix atmp = a.hermitian (); + Matrix btmp = b.transpose (); + + int info; + if (btmp.rows () == btmp.columns ()) + { + double rcond = 0.0; + ComplexMatrix result = btmp.solve (atmp, info, rcond); + if (result_ok (info, rcond)) + return tree_constant (result.hermitian ()); + } + + int rank; + ComplexMatrix result = btmp.lssolve (atmp, info, rank); + + return tree_constant (result.hermitian ()); +} + +/* 4 */ +tree_constant +xdiv (ComplexMatrix& a, ComplexMatrix& b) +{ + if (! mx_div_conform (b.rows (), b.columns (), a.columns ())) + return tree_constant (); + + ComplexMatrix atmp = a.hermitian (); + ComplexMatrix btmp = b.hermitian (); + + int info; + if (btmp.rows () == btmp.columns ()) + { + double rcond = 0.0; + ComplexMatrix result = btmp.solve (atmp, info, rcond); + if (result_ok (info, rcond)) + return tree_constant (result.hermitian ()); + } + + int rank; + ComplexMatrix result = btmp.lssolve (atmp, info, rank); + + return tree_constant (result.hermitian ()); +} + +/* + * Funny element by element division operations. + * + * op2 \ op1: s cs + * +-- +---+----+ + * matrix | 1 | 3 | + * +---+----+ + * complex_matrix | 2 | 4 | + * +---+----+ + */ + +tree_constant +x_el_div (double a, Matrix& b) +{ + int nr = b.rows (); + int nc = b.columns (); + + Matrix result (nr, nc); + + for (int j = 0; j < nc; j++) + for (int i = 0; i < nr; i++) + result.elem (i, j) = a / b.elem (i, j); + + return tree_constant (result); +} + +tree_constant +x_el_div (double a, ComplexMatrix& b) +{ + int nr = b.rows (); + int nc = b.columns (); + + ComplexMatrix result (nr, nc); + + for (int j = 0; j < nc; j++) + for (int i = 0; i < nr; i++) + result.elem (i, j) = a / b.elem (i, j); + + return tree_constant (result); +} + +tree_constant +x_el_div (Complex a, Matrix& b) +{ + int nr = b.rows (); + int nc = b.columns (); + + ComplexMatrix result (nr, nc); + + for (int j = 0; j < nc; j++) + for (int i = 0; i < nr; i++) + result.elem (i, j) = a / b.elem (i, j); + + return tree_constant (result); +} + +tree_constant +x_el_div (Complex a, ComplexMatrix& b) +{ + int nr = b.rows (); + int nc = b.columns (); + + ComplexMatrix result (nr, nc); + + for (int j = 0; j < nc; j++) + for (int i = 0; i < nr; i++) + result.elem (i, j) = a / b.elem (i, j); + + return tree_constant (result); +} + +/* + * Left division functions. + * + * op2 \ op1: m cm + * +-- +---+----+ + * matrix | 1 | 3 | + * +---+----+ + * complex_matrix | 2 | 4 | + * +---+----+ + */ + +/* 1 */ +tree_constant +xleftdiv (Matrix& a, Matrix& b) +{ + if (! mx_leftdiv_conform (a.rows (), a.columns (), b.rows ())) + return tree_constant (); + + int info; + if (a.rows () == a.columns ()) + { + double rcond = 0.0; + Matrix result = a.solve (b, info, rcond); + if (result_ok (info, rcond)) + return tree_constant (result); + } + + int rank; + Matrix result = a.lssolve (b, info, rank); + + return tree_constant (result); +} + +/* 2 */ +tree_constant +xleftdiv (Matrix& a, ComplexMatrix& b) +{ + if (! mx_leftdiv_conform (a.rows (), a.columns (), b.rows ())) + return tree_constant (); + + int info; + if (a.rows () == a.columns ()) + { + double rcond = 0.0; + ComplexMatrix result = a.solve (b, info, rcond); + if (result_ok (info, rcond)) + return tree_constant (result); + } + + int rank; + ComplexMatrix result = a.lssolve (b, info, rank); + + return tree_constant (result); +} + +/* 3 */ +tree_constant +xleftdiv (ComplexMatrix& a, Matrix& b) +{ + if (! mx_leftdiv_conform (a.rows (), a.columns (), b.rows ())) + return tree_constant (); + + int info; + if (a.rows () == a.columns ()) + { + double rcond = 0.0; + ComplexMatrix result = a.solve (b, info, rcond); + if (result_ok (info, rcond)) + return tree_constant (result); + } + + int rank; + ComplexMatrix result = a.lssolve (b, info, rank); + + return tree_constant (result); +} + +/* 4 */ +tree_constant +xleftdiv (ComplexMatrix& a, ComplexMatrix& b) +{ + if (! mx_leftdiv_conform (a.rows (), a.columns (), b.rows ())) + return tree_constant (); + + int info; + if (a.rows () == a.columns ()) + { + double rcond = 0.0; + ComplexMatrix result = a.solve (b, info, rcond); + if (result_ok (info, rcond)) + return tree_constant (result); + } + + int rank; + ComplexMatrix result = a.lssolve (b, info, rank); + + return tree_constant (result); +} + +/* +;;; Local Variables: *** +;;; mode: C++ *** +;;; page-delimiter: "^/\\*" *** +;;; End: *** +*/
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/xdiv.h Sun Aug 08 01:13:40 1993 +0000 @@ -0,0 +1,59 @@ +// xdiv.h -*- C++ -*- +/* + +Copyright (C) 1992, 1993 John W. Eaton + +This file is part of Octave. + +Octave is free software; you can redistribute it and/or modify it +under the terms of the GNU General Public License as published by the +Free Software Foundation; either version 2, or (at your option) any +later version. + +Octave is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +for more details. + +You should have received a copy of the GNU General Public License +along with Octave; see the file COPYING. If not, write to the Free +Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. + +*/ + +#if !defined (_xdiv_h) +#define _xdiv_h 1 + +#ifdef __GNUG__ +#pragma interface +#endif + +#include <Complex.h> + +#include "Matrix.h" + +#include "tree-const.h" + +extern tree_constant xdiv (Matrix& a, Matrix& b); +extern tree_constant xdiv (Matrix& a, ComplexMatrix& b); +extern tree_constant xdiv (ComplexMatrix& a, Matrix& b); +extern tree_constant xdiv (ComplexMatrix& a, ComplexMatrix& b); + +extern tree_constant x_el_div (double a, Matrix& b); +extern tree_constant x_el_div (double a, ComplexMatrix& b); +extern tree_constant x_el_div (Complex a, Matrix& b); +extern tree_constant x_el_div (Complex a, ComplexMatrix& b); + +extern tree_constant xleftdiv (Matrix& a, Matrix& b); +extern tree_constant xleftdiv (Matrix& a, ComplexMatrix& b); +extern tree_constant xleftdiv (ComplexMatrix& a, Matrix& b); +extern tree_constant xleftdiv (ComplexMatrix& a, ComplexMatrix& b); + +#endif + +/* +;;; Local Variables: *** +;;; mode: C++ *** +;;; page-delimiter: "^/\\*" *** +;;; End: *** +*/
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/xpow.cc Sun Aug 08 01:13:40 1993 +0000 @@ -0,0 +1,674 @@ +// xpow.cc -*- C++ -*- +/* + +Copyright (C) 1992, 1993 John W. Eaton + +This file is part of Octave. + +Octave is free software; you can redistribute it and/or modify it +under the terms of the GNU General Public License as published by the +Free Software Foundation; either version 2, or (at your option) any +later version. + +Octave is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +for more details. + +You should have received a copy of the GNU General Public License +along with Octave; see the file COPYING. If not, write to the Free +Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. + +*/ + +#ifdef __GNUG__ +#pragma implementation +#endif + +#include <assert.h> +#include "error.h" +#include "xpow.h" + +// This function also appears in tree-const.cc. Maybe it should be a +// member function of the Matrix class. + +static int +any_element_is_negative (const Matrix& a) +{ + int nr = a.rows (); + int nc = a.columns (); + for (int j = 0; j < nc; j++) + for (int i = 0; i < nr; i++) + if (a.elem (i, j) < 0.0) + return 1; + return 0; +} + +/* + * Safer pow functions. + * + * op2 \ op1: s m cs cm + * +-- +---+---+----+----+ + * scalar | | 1 | 5 | 7 | 11 | + * +---+---+----+----+ + * matrix | 2 | E | 8 | E | + * +---+---+----+----+ + * complex_scalar | 3 | 6 | 9 | 12 | + * +---+---+----+----+ + * complex_matrix | 4 | E | 10 | E | + * +---+---+----+----+ + * + * E -> error, trapped in arith-ops.cc. + */ + +tree_constant +xpow (double a, double b) +{ + if (a < 0.0 && (int) b != b) + { + Complex atmp (a); + return tree_constant (pow (atmp, b)); + } + else + return tree_constant (pow (a, b)); +} + +tree_constant +xpow (double a, Matrix& b) +{ + tree_constant retval; + + int nr = b.rows (); + int nc = b.columns (); + + if (nr == 0 || nc == 0 || nr != nc) + error ("for x^A, A must be square"); + else + { + EIG b_eig (b); + ComplexColumnVector lambda (b_eig.eigenvalues ()); + ComplexMatrix Q (b_eig.eigenvectors ()); + + for (int i = 0; i < nr; i++) + { + Complex elt = lambda.elem (i); + if (imag (elt) == 0.0) + lambda.elem (i) = pow (a, real (elt)); + else + lambda.elem (i) = pow (a, elt); + } + ComplexDiagMatrix D (lambda); + + ComplexMatrix result = Q * D * Q.inverse (); + retval = tree_constant (result); + } + + return retval; +} + +tree_constant +xpow (double a, Complex& b) +{ + Complex result; + Complex atmp (a); + result = pow (atmp, b); + return tree_constant (result); +} + +tree_constant +xpow (double a, ComplexMatrix& b) +{ + tree_constant retval; + + int nr = b.rows (); + int nc = b.columns (); + + if (nr == 0 || nc == 0 || nr != nc) + error ("for x^A, A must be square"); + else + { + EIG b_eig (b); + ComplexColumnVector lambda (b_eig.eigenvalues ()); + ComplexMatrix Q (b_eig.eigenvectors ()); + + for (int i = 0; i < nr; i++) + { + Complex elt = lambda.elem (i); + if (imag (elt) == 0.0) + lambda.elem (i) = pow (a, real (elt)); + else + lambda.elem (i) = pow (a, elt); + } + ComplexDiagMatrix D (lambda); + + ComplexMatrix result = Q * D * Q.inverse (); + retval = tree_constant (result); + } + + return retval; +} + +tree_constant +xpow (Matrix& a, double b) +{ + tree_constant retval; + + int nr = a.rows (); + int nc = a.columns (); + + if (nr == 0 || nc == 0 || nr != nc) + { + error ("for A^b, A must be square"); + return retval; + } + + if ((int) b == b) + { + int btmp = (int) b; + if (btmp == 0) + { + DiagMatrix result (nr, nr, 1.0); + retval = tree_constant (result); + } + else + { +// Too much copying? +// XXX FIXME XXX -- we shouldn\'t do this if the exponent is large... + Matrix atmp; + if (btmp < 0) + { + btmp = -btmp; + atmp = a.inverse (); + } + else + atmp = a; + + Matrix result (atmp); + for (int i = 1; i < btmp; i++) + result = result * atmp; + + retval = tree_constant (result); + } + } + else + { + EIG a_eig (a); + ComplexColumnVector lambda (a_eig.eigenvalues ()); + ComplexMatrix Q (a_eig.eigenvectors ()); + + for (int i = 0; i < nr; i++) + lambda.elem (i) = pow (lambda.elem (i), b); + + ComplexDiagMatrix D (lambda); + + ComplexMatrix result = Q * D * Q.inverse (); + retval = tree_constant (result); + } + + return retval; +} + +tree_constant +xpow (Matrix& a, Complex& b) +{ + int nr = a.rows (); + int nc = a.columns (); + + if (nr == 0 || nc == 0 || nr != nc) + { + error ("for A^b, A must be square"); + return tree_constant (); + } + + EIG a_eig (a); + ComplexColumnVector lambda (a_eig.eigenvalues ()); + ComplexMatrix Q (a_eig.eigenvectors ()); + + for (int i = 0; i < nr; i++) + lambda.elem (i) = pow (lambda.elem (i), b); + + ComplexDiagMatrix D (lambda); + + ComplexMatrix result = Q * D * Q.inverse (); + + return tree_constant (result); +} + +tree_constant +xpow (Complex& a, double b) +{ + Complex result; + result = pow (a, b); + return tree_constant (result); +} + +tree_constant +xpow (Complex& a, Matrix& b) +{ + tree_constant retval; + + int nr = b.rows (); + int nc = b.columns (); + + if (nr == 0 || nc == 0 || nr != nc) + { + error ("for x^A, A must be square"); + } + else + { + EIG b_eig (b); + ComplexColumnVector lambda (b_eig.eigenvalues ()); + ComplexMatrix Q (b_eig.eigenvectors ()); + + for (int i = 0; i < nr; i++) + { + Complex elt = lambda.elem (i); + if (imag (elt) == 0.0) + lambda.elem (i) = pow (a, real (elt)); + else + lambda.elem (i) = pow (a, elt); + } + ComplexDiagMatrix D (lambda); + + ComplexMatrix result = Q * D * Q.inverse (); + retval = tree_constant (result); + } + + return retval; +} + +tree_constant +xpow (Complex& a, Complex& b) +{ + Complex result; + result = pow (a, b); + return tree_constant (result); +} + +tree_constant +xpow (Complex& a, ComplexMatrix& b) +{ + tree_constant retval; + + int nr = b.rows (); + int nc = b.columns (); + + if (nr == 0 || nc == 0 || nr != nc) + error ("for x^A, A must be square"); + else + { + EIG b_eig (b); + ComplexColumnVector lambda (b_eig.eigenvalues ()); + ComplexMatrix Q (b_eig.eigenvectors ()); + + for (int i = 0; i < nr; i++) + { + Complex elt = lambda.elem (i); + if (imag (elt) == 0.0) + lambda.elem (i) = pow (a, real (elt)); + else + lambda.elem (i) = pow (a, elt); + } + ComplexDiagMatrix D (lambda); + + ComplexMatrix result = Q * D * Q.inverse (); + retval = tree_constant (result); + } + + return retval; +} + +tree_constant +xpow (ComplexMatrix& a, double b) +{ + tree_constant retval; + + int nr = a.rows (); + int nc = a.columns (); + + if (nr == 0 || nc == 0 || nr != nc) + { + error ("for A^b, A must be square"); + return retval; + } + + if ((int) b == b) + { + int btmp = (int) b; + if (btmp == 0) + { + DiagMatrix result (nr, nr, 1.0); + retval = tree_constant (result); + } + else + { +// Too much copying? +// XXX FIXME XXX -- we shouldn\'t do this if the exponent is large... + ComplexMatrix atmp; + if (btmp < 0) + { + btmp = -btmp; + atmp = a.inverse (); + } + else + atmp = a; + + ComplexMatrix result (atmp); + for (int i = 1; i < btmp; i++) + result = result * atmp; + + retval = tree_constant (result); + } + } + else + { + EIG a_eig (a); + ComplexColumnVector lambda (a_eig.eigenvalues ()); + ComplexMatrix Q (a_eig.eigenvectors ()); + + for (int i = 0; i < nr; i++) + lambda.elem (i) = pow (lambda.elem (i), b); + + ComplexDiagMatrix D (lambda); + + ComplexMatrix result = Q * D * Q.inverse (); + retval = tree_constant (result); + } + + return retval; +} + +tree_constant +xpow (ComplexMatrix& a, Complex& b) +{ + int nr = a.rows (); + int nc = a.columns (); + + if (nr == 0 || nc == 0 || nr != nc) + { + error ("for A^b, A must be square"); + return tree_constant (); + } + + EIG a_eig (a); + ComplexColumnVector lambda (a_eig.eigenvalues ()); + ComplexMatrix Q (a_eig.eigenvectors ()); + + for (int i = 0; i < nr; i++) + lambda.elem (i) = pow (lambda.elem (i), b); + + ComplexDiagMatrix D (lambda); + + ComplexMatrix result = Q * D * Q.inverse (); + + return tree_constant (result); +} + +/* + * Safer pow functions that work elementwise for matrices. + * + * op2 \ op1: s m cs cm + * +-- +---+---+----+----+ + * scalar | | * | 3 | * | 9 | + * +---+---+----+----+ + * matrix | 1 | 4 | 7 | 10 | + * +---+---+----+----+ + * complex_scalar | * | 5 | * | 11 | + * +---+---+----+----+ + * complex_matrix | 2 | 6 | 8 | 12 | + * +---+---+----+----+ + * + * * -> not needed. + */ + +tree_constant +elem_xpow (double a, Matrix& b) +{ + tree_constant retval; + + int nr = b.rows (); + int nc = b.columns (); + +// For now, assume the worst. + if (a < 0.0) + { + Complex atmp (a); + ComplexMatrix result (nr, nc); + for (int j = 0; j < nc; j++) + for (int i = 0; i < nr; i++) + result.elem (i, j) = pow (atmp, b.elem (i, j)); + + retval = tree_constant (result); + } + else + { + Matrix result (nr, nc); + for (int j = 0; j < nc; j++) + for (int i = 0; i < nr; i++) + result.elem (i, j) = pow (a, b.elem (i, j)); + + retval = tree_constant (result); + } + + return retval; +} + +tree_constant +elem_xpow (double a, ComplexMatrix& b) +{ + int nr = b.rows (); + int nc = b.columns (); + + ComplexMatrix result (nr, nc); + for (int j = 0; j < nc; j++) + for (int i = 0; i < nr; i++) + result.elem (i, j) = pow (a, b.elem (i, j)); + + return tree_constant (result); +} + +tree_constant +elem_xpow (Matrix& a, double b) +{ + tree_constant retval; + + int nr = a.rows (); + int nc = a.columns (); + + if ((int) b != b && any_element_is_negative (a)) + { + ComplexMatrix result (nr, nc); + for (int j = 0; j < nc; j++) + for (int i = 0; i < nr; i++) + { + Complex atmp (a.elem (i, j)); + result.elem (i, j) = pow (atmp, b); + } + + retval = tree_constant (result); + } + else + { + Matrix result (nr, nc); + for (int j = 0; j < nc; j++) + for (int i = 0; i < nr; i++) + result.elem (i, j) = pow (a.elem (i, j), b); + + retval = tree_constant (result); + } + + return retval; +} + +tree_constant +elem_xpow (Matrix& a, Matrix& b) +{ + int nr = a.rows (); + int nc = a.columns (); + + assert (nr == b.rows () && nc == b.columns ()); + + int convert_to_complex = 0; + int i; + for (int j = 0; j < nc; j++) + for (i = 0; i < nr; i++) + { + double atmp = a.elem (i, j); + double btmp = b.elem (i, j); + if (atmp < 0.0 && (int) btmp != btmp) + { + convert_to_complex = 1; + goto done; + } + } + + done: + + if (convert_to_complex) + { + ComplexMatrix complex_result (nr, nc); + + for (j = 0; j < nc; j++) + for (i = 0; i < nr; i++) + { + Complex atmp (a.elem (i, j)); + Complex btmp (b.elem (i, j)); + complex_result.elem (i, j) = pow (atmp, btmp); + } + return tree_constant (complex_result); + } + else + { + Matrix result (nr, nc); + + for (j = 0; j < nc; j++) + for (i = 0; i < nr; i++) + result.elem (i, j) = pow (a.elem (i, j), b.elem (i, j)); + + return tree_constant (result); + } +} + +tree_constant +elem_xpow (Matrix& a, Complex& b) +{ + int nr = a.rows (); + int nc = a.columns (); + + ComplexMatrix result (nr, nc); + for (int j = 0; j < nc; j++) + for (int i = 0; i < nr; i++) + result.elem (i, j) = pow (a.elem (i, j), b); + + return tree_constant (result); +} + +tree_constant +elem_xpow (Matrix& a, ComplexMatrix& b) +{ + int nr = a.rows (); + int nc = a.columns (); + + assert (nr == b.rows () && nc == b.columns ()); + + ComplexMatrix result (nr, nc); + for (int j = 0; j < nc; j++) + for (int i = 0; i < nr; i++) + result.elem (i, j) = pow (a.elem (i, j), b.elem (i, j)); + + return tree_constant (result); +} + +tree_constant +elem_xpow (Complex& a, Matrix& b) +{ + int nr = b.rows (); + int nc = b.columns (); + + ComplexMatrix result (nr, nc); + for (int j = 0; j < nc; j++) + for (int i = 0; i < nr; i++) + result.elem (i, j) = pow (a, b.elem (i, j)); + + return tree_constant (result); +} + +tree_constant +elem_xpow (Complex& a, ComplexMatrix& b) +{ + int nr = b.rows (); + int nc = b.columns (); + + ComplexMatrix result (nr, nc); + for (int j = 0; j < nc; j++) + for (int i = 0; i < nr; i++) + result.elem (i, j) = pow (a, b.elem (i, j)); + + return tree_constant (result); +} + +tree_constant +elem_xpow (ComplexMatrix& a, double b) +{ + int nr = a.rows (); + int nc = a.columns (); + + ComplexMatrix result (nr, nc); + for (int j = 0; j < nc; j++) + for (int i = 0; i < nr; i++) + result.elem (i, j) = pow (a.elem (i, j), b); + + return tree_constant (result); +} + +tree_constant +elem_xpow (ComplexMatrix& a, Matrix& b) +{ + int nr = a.rows (); + int nc = a.columns (); + + assert (nr == b.rows () && nc == b.columns ()); + + ComplexMatrix result (nr, nc); + for (int j = 0; j < nc; j++) + for (int i = 0; i < nr; i++) + result.elem (i, j) = pow (a.elem (i, j), b.elem (i, j)); + + return tree_constant (result); +} + +tree_constant +elem_xpow (ComplexMatrix& a, Complex& b) +{ + int nr = a.rows (); + int nc = a.columns (); + + ComplexMatrix result (nr, nc); + for (int j = 0; j < nc; j++) + for (int i = 0; i < nr; i++) + result.elem (i, j) = pow (a.elem (i, j), b); + + return tree_constant (result); +} + +tree_constant +elem_xpow (ComplexMatrix& a, ComplexMatrix& b) +{ + int nr = a.rows (); + int nc = a.columns (); + + ComplexMatrix result (nr, nc); + + for (int j = 0; j < nc; j++) + for (int i = 0; i < nr; i++) + result.elem (i, j) = pow (a.elem (i, j), b.elem (i, j)); + + return tree_constant (result); +} + +/* +;;; Local Variables: *** +;;; mode: C++ *** +;;; page-delimiter: "^/\\*" *** +;;; End: *** +*/
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/xpow.h Sun Aug 08 01:13:40 1993 +0000 @@ -0,0 +1,76 @@ +// xpow.h -*- C++ -*- +/* + +Copyright (C) 1992, 1993 John W. Eaton + +This file is part of Octave. + +Octave is free software; you can redistribute it and/or modify it +under the terms of the GNU General Public License as published by the +Free Software Foundation; either version 2, or (at your option) any +later version. + +Octave is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +for more details. + +You should have received a copy of the GNU General Public License +along with Octave; see the file COPYING. If not, write to the Free +Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. + +*/ + +#if !defined (_xpow_h) +#define _xpow_h 1 + +#ifdef __GNUG__ +#pragma interface +#endif + +#include <Complex.h> + +#include "Matrix.h" + +#include "tree-const.h" + +extern tree_constant xpow (double a, double b); +extern tree_constant xpow (double a, Matrix& b); +extern tree_constant xpow (double a, Complex& b); +extern tree_constant xpow (double a, ComplexMatrix& b); + +extern tree_constant xpow (Matrix& a, double b); +extern tree_constant xpow (Matrix& a, Complex& b); + +extern tree_constant xpow (Complex& a, double b); +extern tree_constant xpow (Complex& a, Matrix& b); +extern tree_constant xpow (Complex& a, Complex& b); +extern tree_constant xpow (Complex& a, ComplexMatrix& b); + +extern tree_constant xpow (ComplexMatrix& a, double b); +extern tree_constant xpow (ComplexMatrix& a, Complex& b); + +extern tree_constant elem_xpow (double a, Matrix& b); +extern tree_constant elem_xpow (double a, ComplexMatrix& b); + +extern tree_constant elem_xpow (Matrix& a, double b); +extern tree_constant elem_xpow (Matrix& a, Matrix& b); +extern tree_constant elem_xpow (Matrix& a, Complex& b); +extern tree_constant elem_xpow (Matrix& a, ComplexMatrix& b); + +extern tree_constant elem_xpow (Complex& a, Matrix& b); +extern tree_constant elem_xpow (Complex& a, ComplexMatrix& b); + +extern tree_constant elem_xpow (ComplexMatrix& a, double b); +extern tree_constant elem_xpow (ComplexMatrix& a, Matrix& b); +extern tree_constant elem_xpow (ComplexMatrix& a, Complex& b); +extern tree_constant elem_xpow (ComplexMatrix& a, ComplexMatrix& b); + +#endif + +/* +;;; Local Variables: *** +;;; mode: C++ *** +;;; page-delimiter: "^/\\*" *** +;;; End: *** +*/