Cafe Versioin 2.2 (BIN)
山田邦博です。
Cafe の version up です。 Version 2.2 となりました。
複素数を手軽に扱える(RPN)関数電卓です。
電気・電子工学の研究開発に携わる研究者、技術者のためのものです。
今回の主な変更は、Scalar 値を取り扱う unary および binary operator に
関しては、配列の各要素への自動適用が可能になったことです(関数定義で
array expandable が宣言されている場合)。
詳細は下記 web ペイジを参照して下さい。
http://www.tksa.gr.jp/king/Software/Cafe/Cafe.html
-...-
本投稿は 2部に分けます。
DOC (diff)(先のドキュメント部)
BIN (diff+shar)(今回投稿分)
-...-
アーカイブ:
----------
Cafe Ver.2.2 の全てのファイルは
ftp://ftp.tksa.gr.jp/king/Cafe/Cafe_2.2.tgz
にあります。
最新の Cafe (patch 版を含む)については
http://www.tksa.gr.jp/king/Software/Cafe/
からたどって下さい。
=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=
#!/bin/sh
# This is a shell archive (produced by GNU sharutils 4.2.1).
# To extract the files from this archive, save it to some FILE, remove
# everything before the `!/bin/sh' line above, then type `sh FILE'.
#
# Made on 2004-12-01 23:16 JST by <king@owlin>.
# Source directory was `/home/king/tmp'.
#
# Existing files will *not* be overwritten unless `-c' is specified.
#
# This shar contains:
# length mode name
# ------ ---------- ------------------------------------------
# 48934 -rw-r--r-- Cafe.bin.diff
#
save_IFS="${IFS}"
IFS="${IFS}:"
gettext_dir=FAILED
locale_dir=FAILED
first_param="$1"
for dir in $PATH
do
if test "$gettext_dir" = FAILED && test -f $dir/gettext \
&& ($dir/gettext --version >/dev/null 2>&1)
then
set `$dir/gettext --version 2>&1`
if test "$3" = GNU
then
gettext_dir=$dir
fi
fi
if test "$locale_dir" = FAILED && test -f $dir/shar \
&& ($dir/shar --print-text-domain-dir >/dev/null 2>&1)
then
locale_dir=`$dir/shar --print-text-domain-dir`
fi
done
IFS="$save_IFS"
if test "$locale_dir" = FAILED || test "$gettext_dir" = FAILED
then
echo=echo
else
TEXTDOMAINDIR=$locale_dir
export TEXTDOMAINDIR
TEXTDOMAIN=sharutils
export TEXTDOMAIN
echo="$gettext_dir/gettext -s"
fi
if touch -am -t 200112312359.59 $$.touch >/dev/null 2>&1 && test ! -f 200112312359.59 -a -f $$.touch; then
shar_touch='touch -am -t $1$2$3$4$5$6.$7 "$8"'
elif touch -am 123123592001.59 $$.touch >/dev/null 2>&1 && test ! -f 123123592001.59 -a ! -f 123123592001.5 -a -f $$.touch; then
shar_touch='touch -am $3$4$5$6$1$2.$7 "$8"'
elif touch -am 1231235901 $$.touch >/dev/null 2>&1 && test ! -f 1231235901 -a -f $$.touch; then
shar_touch='touch -am $3$4$5$6$2 "$8"'
else
shar_touch=:
echo
$echo 'WARNING: not restoring timestamps. Consider getting and'
$echo "installing GNU \`touch', distributed in GNU File Utilities..."
echo
fi
rm -f 200112312359.59 123123592001.59 123123592001.5 1231235901 $$.touch
#
if mkdir _sh06517; then
$echo 'x -' 'creating lock directory'
else
$echo 'failed to create lock directory'
exit 1
fi
# ============= Cafe.bin.diff ==============
if test -f 'Cafe.bin.diff' && test "$first_param" != -c; then
$echo 'x -' SKIPPING 'Cafe.bin.diff' '(file already exists)'
else
$echo 'x -' extracting 'Cafe.bin.diff' '(text)'
sed 's/^X//' << 'SHAR_EOF' > 'Cafe.bin.diff' &&
diff -urN Cafe_2.2-pre.1/bin/cafe Cafe_2.2/bin/cafe
--- Cafe_2.2-pre.1/bin/cafe 2004-01-31 11:45:49.000000000 +0900
+++ Cafe_2.2/bin/cafe 2004-12-01 18:16:07.000000000 +0900
@@ -24,15 +24,11 @@
X # 11 May 2000 Ver.0.1
X # 30 May 2000 Ver.0.2
X # 18 Aug.2000 Ver.0.3
-# 4 Mar.2003 Ver.1.0 (Released)
-# 20 Mar.2003 Ver.1.1 (Released)
-# 15 Apr.2003 Ver.2.0-pre.1 (Pre-released)
-# 5 May 2003 Ver.2.0-pre.2 (Pre-released)
-# 15 May 2003 Ver.2.0 (Released)
-# 22 May 2003 Ver.2.0-patch.1 (Released)
-# 24 Dec.2003 Ver.2.1-pre.1 (Pre-released)
-# 3 Jan.2004 Ver.2.1 (Released)
-# 31 Jan.2004 Ver.2.1-patch.1 (Released)
+# 4 Mar.2003 Ver.1.0
+# 20 Mar.2003 Ver.1.1
+# 15 May 2003 Ver.2.0
+# 3 Jan.2004 Ver.2.1
+# 1 Dec.2004 Ver.2.2
X #
X
X no lib qw(:ALL .);
@@ -72,7 +68,7 @@
X
X if ($opt_v) {
X my @n = cafeine("sysver\n");
- print "\nThis is Cafe version $n[0]\n\n",
+ print "\nThis is Cafe version $n[0].\n\n",
X "Copyright 2000-2004, YAMADA Kunihiro <king\@tksa.gr.jp>\n\n",
X "You can get the latest version from\n",
X "\thttp://www.tksa.gr.jp/king/Software/Cafe/\n\n";
diff -urN Cafe_2.2-pre.1/bin/fix-new-version.sh Cafe_2.2/bin/fix-new-version.sh
--- Cafe_2.2-pre.1/bin/fix-new-version.sh 1970-01-01 09:00:00.000000000 +0900
+++ Cafe_2.2/bin/fix-new-version.sh 2004-12-01 18:16:47.000000000 +0900
@@ -0,0 +1,98 @@
+#!/bin/bash
+
+# fix-new-version.sh : Fix new version for the set of Cafe.
+#
+
+# Usage:
+# fix-new-version.sh
+#
+# Note:
+# Version of cafe is fetched from in the source.
+#
+
+# Author:
+# YAMADA Kunihiro <king@tksa.gr.jp>
+# (http://www.tksa.gr.jp/king/)
+#
+# Copyright policy:
+# GNU GPL Ver.2
+#
+# History:
+# 17 Oct.2003
+# 26 Nov.2003 bug fixed
+# 3 Dec.2003 message corrected.
+# 3 Jan.2004 added word.cafe to LIB
+# 13 Jan.2004 added minimize_error.cafe to LIB
+# 15 Nov.2004 added compensate.small.speaker.cafe to EXM
+# 20 Nov.2004 added fix-new-version.sh
+# 1 Dec.2004 released with cafe ver.2.2.
+#
+
+set -e
+
+### List of files to be installed ###
+BIN="cafe install.sh fix-new-version.sh"
+LIB="Cafe.pm define.cafe antenna.cafe music.cafe diagnosis.cafe word.cafe minimize_error.cafe"
+DOC="BNF.txt BUGS.jp.txt DIAGNOSIS.jp.txt GPL-2 INSTALL.jp.txt MUMBLE.jp.txt README.jp.txt TODO.jp.txt VERSION.jp.txt change.log"
+EXM="filts4.cafe compensate.small.speaker.cafe"
+
+# Constants
+PKG=Cafe
+PRGVER=$PKG.pm
+SRCBASE=${0%/*}/..
+
+
+VERSION=$( \
+ perl -ne 'next unless /^my\s+\$VERSION\s*=\s*\"(\S+)\"\s*;/; \
+ print $1; exit 0;' \
+ $SRCBASE/lib/$PRGVER; \
+ )
+if [ "$VERSION" == "" ]; then
+ echo "Version is not found in $PRGVER." >&2
+ exit 1
+fi
+
+echo "New Version of $PKG is \"$VERSION\"."
+echo -n "OK?(y/N) "
+read ans
+if [ "$ans" != "y" -a "$ans" != "Y" ]; then
+ echo "Fixing skipped."
+ exit 0
+fi
+
+
+DSTBASE=${0%/*}/../../${PKG}_$VERSION
+
+if [ -e $DSTBASE ]; then
+ echo "\"$DSTBASE\" exists already." >&2
+ exit 1
+fi
+
+mkdir -m 0755 $DSTBASE
+mkdir -m 0755 $DSTBASE/{bin,lib,doc}
+mkdir -m 0755 $DSTBASE/doc/example
+
+for f in $BIN; do
+ cp -p $SRCBASE/bin/$f $DSTBASE/bin/
+ chmod 755 $DSTBASE/bin/$f
+done
+
+for f in $LIB; do
+ cp -p $SRCBASE/lib/$f $DSTBASE/lib/
+ chmod 644 $DSTBASE/lib/$f
+done
+
+for f in $DOC; do
+ cp -p $SRCBASE/doc/$f $DSTBASE/doc/
+ chmod 644 $DSTBASE/doc/$f
+done
+if [ -f $DSTBASE/doc/GPL-2 ]; then
+ chmod 444 $DSTBASE/doc/GPL-2
+fi
+for f in $EXM; do
+ cp -p $SRCBASE/doc/example/$f $DSTBASE/doc/example/
+ chmod 644 $DSTBASE/doc/example/$f
+done
+
+echo "Finished."
+exit 0
diff -urN Cafe_2.2-pre.1/bin/install.sh Cafe_2.2/bin/install.sh
--- Cafe_2.2-pre.1/bin/install.sh 2004-01-31 11:46:41.000000000 +0900
+++ Cafe_2.2/bin/install.sh 2004-12-01 18:17:30.000000000 +0900
@@ -24,15 +24,14 @@
X # History:
X # 4 Mar.2003 install cafe Ver.1.0
X # 11 Mar.2003 install_dir can be specified
-# 20 Mar.2003 Ver.1.1 (Released)
-# 15 Apr.2003 Ver.2.0-pre.1 (Pre-relesed)
+# 20 Mar.2003 Ver.1.1
X # 20 Apr.2003 bug fixed: "=" <- "==" for test
X # 4 May 2003 don't install for home
X # 5 May 2003 -d: deinstall option
-# 15 May 2003 Ver.2.0 (Released)
-# 22 May 2003 Ver.2.0-patch.1
-# 3 Jan.2004 Ver.2.1 (Released)
-# 31 Jan.2004 Ver.2.1-patch.1 (Released)
+# 15 May 2003 Ver.2.0
+# 22 May 2003 Ver.2.0
+# 3 Jan.2004 Ver.2.1
+# 1 Dec.2004 Ver.2.2
X #
X
X set -e
diff -urN Cafe_2.2-pre.1/lib/Cafe.pm Cafe_2.2/lib/Cafe.pm
--- Cafe_2.2-pre.1/lib/Cafe.pm 2004-11-05 00:56:08.000000000 +0900
+++ Cafe_2.2/lib/Cafe.pm 2004-12-01 18:21:19.000000000 +0900
@@ -20,16 +20,11 @@
X # 11 May 2000 Ver.0.1
X # 30 May 2000 Ver.0.2
X # 18 Aug.2000 Ver.0.3
-# 4 Mar.2003 Ver.1.0 (Released)
-# 20 Mar.2003 Ver.1.1 (Released)
-# 15 Apr.2003 Ver.2.0-pre.1 (Pre-released)
-# 5 May 2003 Ver.2.0-pre.2 (Pre-released)
-# 15 May 2003 Ver.2.0 (Released)
-# 22 May 2003 Ver.2.0-patch.1 (Released)
-# 24 Dec 2003 Ver.2.1-pre.1 (Pre-released)
-# 3 Jan.2004 Ver.2.1 (Released)
-# 31 Jan.2004 Ver.2.1-patch.1 (Released)
-# 5 Nov.2004 Ver.2.2-pre.1 (Released)
+# 4 Mar.2003 Ver.1.0
+# 20 Mar.2003 Ver.1.1
+# 15 May 2003 Ver.2.0
+# 3 Jan.2004 Ver.2.1
+# 1 Dec.2004 Ver.2.2
X #
X
X
@@ -62,6 +57,9 @@
X # name: string of it's ID (name)
X # comment: comment for function, binary operator, variable or constant.
X # flag: set 1 when pushed on a stack.
+# arrayex: array extension for Unary or Binary operator
+# 1: array expandable
+# 0 or undefined: not expandable
X #
X
X package Cafe;
@@ -82,7 +80,7 @@
X ### Constants ###
X ###################
X
-my $VERSION = "2.2-pre.1";
+my $VERSION = "2.2";
X
X my $INF = 1e9999999999;
X my $NAN = $INF - $INF;
@@ -102,12 +100,14 @@
X my $PTN_SPECIAL = "$PTN_BINARY|$PTN_REDUCTION|$PTN_UNARY";
X my $PTN_BRACKET = '\[[^\[\]]*\]\s*';
X my $PTN_CONTINUATION = "\\\\\\s*\$";
+my $PTN_ARRAYEX = 'array_expandable|arrayex|ax';
X
X my $ID_BLANK_OP = ' Blank Operator ';
X my $ID_UN_PLUS = ' Unary + ';
X my $ID_UN_MINUS = ' Unary - ';
X
-my @RESERVED_ID = qw(def undef pop stack if elsif else for while do);
+my @RESERVED_ID = qw(def undef pop stack if elsif else for while do
+ constant nullary unary binary array_expandable);
X
X my %CONTROL_CHAR = (a=>"\a", b=>"\b", e=>"\e", f=>"\f",
X n=>"\n", r=>"\r", t=>"\t");
@@ -264,6 +264,8 @@
X ## Function executor ##
X #######################
X
+sub execute_function ( $;$ );
+
X sub execute_function ( $;$ ) {
X my ($vid,$check_stack) = @_;
X # print "#",__LINE__,"# execute_function: check_stack=\"$check_stack\"\n" if $DEBUG;
@@ -281,12 +283,97 @@
X # print "#",__LINE__,"# execute_function: id=\"$id\"\n" if $DEBUG;
X die "!!BUG!! exec: \"$id\" is not function: "
X unless $op->{type} eq 'F' or $op->{type} eq 'B';
+ die "!!BUG!! exec: \"$id\" : too less stack: " if nvstack() < $op->{narg};
+ if (defined $op->{arrayex} and $op->{arrayex}) {
+ if ($op->{type} eq 'F' and $op->{narg} == 1) {
+ ### Unary ###
+ my $v = popvstack();
+ if ($v->{type} eq 'A') {
+ ## array
+ my $ans = makearray();
+ $v->{name} =~ /(\[.*)/;
+ $ans->{name} = $id . ($1 ? $1 : "");
+ my $n = @{$v->{value}};
+ for (my $i=0; $i<$n; ++$i) {
+ pushvstack($v->{value}[$i]);
+ execute_function($op,1);
+ $ans->{value}[$i] = popvstack();
+ $ans->{value}[$i]->{name} = $ans->{name} . "\[$i\]";
+ }
+ pushvstack($ans);
+ return;
+ } else {
+ ## Not array
+ pushvstack($v);
+ }
+ } elsif ($op->{type} eq 'B') {
+ ### Binary ###
+ my $right = popvstack();
+ my $left = popvstack();
+ if ($left->{type} eq "A") {
+ ## array op *
+ my $n = @{$left->{value}};
+ DIE("\"$id\" : null array : \"$left->{name}\"\n",$left,$right)
+ unless $n > 0;
+ my $ans = makearray;
+ $left->{name} =~ /(\[.*)/;
+ $ans->{name} = $id . ($1 ? $1 : "");
+ if ($right->{type} eq "A") {
+ ## array op array
+ DIE("\"$id\" : incompatible arrays : \"$left->{name}\" and \"$right->{name}\"\n",
+ $left,$right)
+ unless $n == @{$right->{value}};
+ for (my $i=0; $i<$n; ++$i) {
+ pushvstack($left->{value}[$i]);
+ pushvstack($right->{value}[$i]);
+ execute_function($op,1);
+ $ans->{value}[$i] = popvstack();
+ $ans->{value}[$i]->{name} = $ans->{name} . "\[$i\]";
+ }
+ } else {
+ ## array op scalar
+ for (my $i=0; $i<$n; ++$i) {
+ pushvstack($left->{value}[$i]);
+ pushvstack($right);
+ execute_function($op,1);
+ $ans->{value}[$i] = popvstack();
+ $ans->{value}[$i]->{name} = $ans->{name} . "\[$i\]";
+ }
+ }
+ pushvstack($ans);
+ return;
+ } elsif ($right->{type} eq "A") {
+ ## scalar op array
+ my $ans = makearray;
+ $right->{name} =~ /(\[.*)/;
+ $ans->{name} = $id . ($1 ? $1 : "");
+ my $n = @{$right->{value}};
+ DIE("\"$id\" : null array : \"$right->{name}\"\n",$left,$right)
+ unless $n > 0;
+ for (my $i=0; $i<$n; ++$i) {
+ pushvstack($left);
+ pushvstack($right->{value}[$i]);
+ execute_function($op,1);
+ $ans->{value}[$i] = popvstack();
+ $ans->{value}[$i]->{name} = $ans->{name} . "\[$i\]";
+ }
+ pushvstack($ans);
+ return;
+ } else {
+ ## scalar op scalar
+ pushvstack($left);
+ pushvstack($right);
+ }
+ } else {
+ die "!!BUG!! exec: Bad array extension : \"$id\" :"
+ }
+ }
X if (ref($op->{value}) eq 'CODE') {
X ## System defined function ##
X my $ref = $op->{ref};
X my @stk;
X my $i;
- die "!!BUG!! exec: $id : too less stack: " if nvstack() < $op->{narg};
+# die "!!BUG!! exec: $id : too less stack: " if nvstack() < $op->{narg};
X for ($i=1;$i<=$op->{narg};++$i) {
X die "!!BUG!! exec: Bad \"$id->\{ref\}: "
X unless $ref =~ s/.$//;
@@ -327,7 +414,7 @@
X $cmdbgn = $cmdpnt += length $&;
X my @stk;
X my $i;
- die "!!BUG!! exec: too less stack: " if nvstack() < $op->{narg};
+# die "!!BUG!! exec: too less stack: " if nvstack() < $op->{narg};
X for ($i=1;$i<=$op->{narg};++$i) {
X push @stk,popvstack();
X }
@@ -382,7 +469,7 @@
X pop_localID();
X pop_cmdln();
X }
-}
+} # end of execute_function
X
X ##################
X ### Arithmetic ###
@@ -489,7 +576,7 @@
X } else {
X die "!!BUG!! arith: \"$opid\" bad operator: ";
X }
-}
+} # end of arith
X
X sub cexp ( $ ) {
X my $a = shift;
@@ -619,7 +706,7 @@
X assign($ans->{value}[$i_ans], cmplx($ax[$i],$ay[$i]));
X }
X pushvstack($ans);
-}
+} # end of c_fft
X
X
X ############################
@@ -710,65 +797,12 @@
X return ($left,$right)
X }
X
-sub _op_bin_arith ( $ );
-
X sub _op_bin_arith ( $ ) {
X my $opid = shift;
- my $right = popvstack();
- my $left = popvstack();
- if ($left->{type} eq "A") {
- my $n = @{$left->{value}};
- DIE("\"$opid\" : null array : \"$left->{name}\"\n",$left,$right)
- unless $n > 0;
- my $ans = makearray;
- $left->{name} =~ /(\[.*)/;
- $ans->{name} = $opid . ($1 ? $1 : "");
- if ($right->{type} eq "A") {
- DIE("\"$opid\" : incompatible arrays : \"$left->{name}\" and \"$right->{name}\"\n",
- $left,$right)
- unless $n == @{$right->{value}};
- for (my $i=0; $i<$n; ++$i) {
- pushvstack($left->{value}[$i]);
- pushvstack($right->{value}[$i]);
- _op_bin_arith($opid);
- $ans->{value}[$i] = popvstack();
- $ans->{value}[$i]->{name} = $ans->{name} . "\[$i\]";
- }
- pushvstack($ans);
- } else {
- for (my $i=0; $i<$n; ++$i) {
- pushvstack($left->{value}[$i]);
- pushvstack($right);
- _op_bin_arith($opid);
- $ans->{value}[$i] = popvstack();
- $ans->{value}[$i]->{name} = $ans->{name} . "\[$i\]";
- }
- pushvstack($ans);
- }
- } elsif ($right->{type} eq "A") {
- my $ans = makearray;
- $right->{name} =~ /(\[.*)/;
- $ans->{name} = $opid . ($1 ? $1 : "");
- my $n = @{$right->{value}};
- DIE("\"$opid\" : null array : \"$right->{name}\"\n",$left,$right)
- unless $n > 0;
- for (my $i=0; $i<$n; ++$i) {
- pushvstack($left);
- pushvstack($right->{value}[$i]);
- _op_bin_arith($opid);
- $ans->{value}[$i] = popvstack();
- $ans->{value}[$i]->{name} = $ans->{name} . "\[$i\]";
- }
- pushvstack($ans);
- } else {
- pushvstack($left);
- pushvstack($right);
- check_bin_num($opid);
- pushvstack(arith($left,$right,$opid));
- }
+ my ($left,$right) = check_bin_num($opid);
+ pushvstack(arith($left,$right,$opid));
X }
X
-
X sub op_add () { _op_bin_arith('+') }
X sub op_sub () { _op_bin_arith('-') }
X sub op_mul () { _op_bin_arith('*') }
@@ -909,29 +943,29 @@
X pushvstack(bool( (Re($left) or Re($right) ? 1 : 0) ));
X }
X
-sub setsysbin ( $$$$ );
+sub setsysbin ( $$$$$ );
X
-setsysbin("^",\&op_pwr,100,'Complex power');
-setsysbin($ID_BLANK_OP,\&op_blank,110,
+setsysbin("^",\&op_pwr,100,1,'Complex power');
+setsysbin($ID_BLANK_OP,\&op_blank,110,1,
X 'Blank operator (Same as complex multiplication "*" except priority)');
-setsysbin("*",\&op_mul,120,'Complex Multiplication');
-setsysbin("/",\&op_div,120,'Complex Division');
-setsysbin("%",\&op_residual,120,'Complex Residual');
-setsysbin("+",\&op_add,130,'Complex Addition');
-setsysbin("-",\&op_sub,130,'Complex Subtraction');
-setsysbin("//",\&op_para,200,'Parallel impedance');
-setsysbin(".*",\&op_strmul,300,'String multiplication');
-setsysbin(".",\&op_strcon,310,'String concatination');
-setsysbin("eq",\&op_equal_str,500,"String equality");
-setsysbin("ne",\&op_notequal_str,500,"String inequality");
-setsysbin("==",\&op_equal_num,500,'Complex equality');
-setsysbin("!=",\&op_notequal_num,500,'Complex inequality');
-setsysbin(">",\&op_gt,500,'Arithmetic greater than');
-setsysbin(">=",\&op_ge,500,'Arithmetic greater than or equal to');
-setsysbin("<",\&op_lt,500,'Arithmetic less than');
-setsysbin("<=",\&op_le,500,'Arithmetic less than or equal to');
-setsysbin("&",\&op_and,1000,'Logical and');
-setsysbin("|",\&op_or,1010,'Logical or');
+setsysbin("*",\&op_mul,120,1,'Complex Multiplication');
+setsysbin("/",\&op_div,120,1,'Complex Division');
+setsysbin("%",\&op_residual,120,1,'Complex Residual');
+setsysbin("+",\&op_add,130,1,'Complex Addition');
+setsysbin("-",\&op_sub,130,1,'Complex Subtraction');
+setsysbin("//",\&op_para,200,1,'Parallel impedance');
+setsysbin(".*",\&op_strmul,300,1,'String multiplication');
+setsysbin(".",\&op_strcon,310,1,'String concatination');
+setsysbin("eq",\&op_equal_str,500,1,'String equality');
+setsysbin("ne",\&op_notequal_str,500,1,'String inequality');
+setsysbin("==",\&op_equal_num,500,1,'Complex equality');
+setsysbin("!=",\&op_notequal_num,500,1,'Complex inequality');
+setsysbin(">",\&op_gt,500,1,'Arithmetic greater than');
+setsysbin(">=",\&op_ge,500,1,'Arithmetic greater than or equal to');
+setsysbin("<",\&op_lt,500,1,'Arithmetic less than');
+setsysbin("<=",\&op_le,500,1,'Arithmetic less than or equal to');
+setsysbin("&",\&op_and,1000,1,'Logical AND');
+setsysbin("|",\&op_or,1010,1,'Logical OR');
X
X
X ########################################
@@ -1039,7 +1073,7 @@
X } else {
X return '<<UNTYPE>>';
X }
-}
+} # end of Stringify
X
X sub Bool ( $ ) {
X my $v = shift;
@@ -1115,20 +1149,21 @@
X c_fft(1);
X }
X
-sub setsysfunc ( $$$$;$ );
+sub setsysfunc ( $$$$;$ );
+sub setsysunary ( $$$$;$ );
X
-setsysfunc("Re",\&op_Re,1,'"Unary" Real part of complex number.');
-setsysfunc("Im",\&op_Im,1,'"Unary" Imaginary part of complex number.');
-setsysfunc("exp",\&op_exp,1,'"Unary" Natural exponent.');
-setsysfunc("log",\&op_log,1,'"Unary" Natural logarithm.');
+setsysunary("Re",\&op_Re,1,'"Unary" Real part of complex number.');
+setsysunary("Im",\&op_Im,1,'"Unary" Imaginary part of complex number.');
+setsysunary("exp",\&op_exp,1,'"Unary" Natural exponent.');
+setsysunary("log",\&op_log,1,'"Unary" Natural logarithm.');
X setsysfunc("ratan2",\&op_ratan2,2,'Real version of atan2(y,x)');
-setsysfunc("int",\&op_int,1,"\"Unary\" Make integer.\n\tTrancate fractional parts of each absolute values of real and imaginary.");
-setsysfunc($ID_UN_PLUS,\&op_un_plus,1,"Unary plus");
-setsysfunc($ID_UN_MINUS,\&op_un_minus,1,"Unary minus");
-setsysfunc("~",\&op_conjugate,1,'"Unary" Complex conjugate.');
-setsysfunc("!",\&op_negate,1,'"Unary" Negate boolean.');
-setsysfunc("fft",\&op_fft,1,'"Unary" Fast Fourier Transform');
-setsysfunc("ifft",\&op_ifft,1,'"Unary" Inverse Fast Fourier Transform');
+setsysunary("int",\&op_int,1,"\"Unary\" Make integer.\n\tTrancate fractional parts of each absolute values of real and imaginary.");
+setsysunary($ID_UN_PLUS,\&op_un_plus,1,"Unary plus");
+setsysunary($ID_UN_MINUS,\&op_un_minus,1,"Unary minus");
+setsysunary("~",\&op_conjugate,1,'"Unary" Complex conjugate.');
+setsysunary("!",\&op_negate,1,'"Unary" Negate boolean.');
+setsysunary("fft",\&op_fft,0,'"Unary" Fast Fourier Transform');
+setsysunary("ifft",\&op_ifft,0,'"Unary" Inverse Fast Fourier Transform');
X
X
X ###########################
@@ -1277,18 +1312,18 @@
X pushvstack(bool($bool));
X }
X
-setsysfunc("push",\&op_push,1,'"Unary" Push variable without flag');
-setsysfunc("narray",\&op_narray,1,'"Unary" Get number of array elements');
-setsysfunc("apop",\&op_apop,1,'"Unary" Pop from array','@');
-setsysfunc("ashift",\&op_ashift,1,'"Unary" Shift from array','@');
-setsysfunc("split",\&op_split,1,'"Unary" Split string to array');
-setsysfunc("join",\&op_join,1,
+setsysunary("push",\&op_push,0,'"Unary" Push variable without flag');
+setsysunary("narray",\&op_narray,0,'"Unary" Get number of array elements');
+setsysunary("apop",\&op_apop,0,'"Unary" Pop from array','@');
+setsysunary("ashift",\&op_ashift,0,'"Unary" Shift from array','@');
+setsysunary("split",\&op_split,1,'"Unary" Split string to array');
+setsysunary("join",\&op_join,0,
X '"Unary" Join character elements of array into single string');
-setsysfunc("vtype",\&op_vtype,1,'"Unary" Get type of variable');
-setsysfunc("has_inf",\&op_has_inf,1,'"Unary" Has some INF(infinity)?');
-setsysfunc("is_nan",\&op_is_nan,1,'"Unary" Is NAN(Non Arithmetic Number)?');
-setsysfunc("is_declared",\&op_is_declared,1,'"Unary" Is declared?');
-setsysfunc("is_defined",\&op_is_defined,1,'"Unary" Is defined?');
+setsysunary("vtype",\&op_vtype,0,'"Unary" Get type of variable');
+setsysunary("has_inf",\&op_has_inf,1,'"Unary" Has some INF(infinity)?');
+setsysunary("is_nan",\&op_is_nan,1,'"Unary" Is NAN(Non Arithmetic Number)?');
+setsysunary("is_declared",\&op_is_declared,1,'"Unary" Is declared?');
+setsysunary("is_defined",\&op_is_defined,1,'"Unary" Is defined?');
X
X
X #############################
@@ -1336,10 +1371,10 @@
X setsysfunc("date",\&op_date,0,'"Nullary" Local time.');
X setsysfunc("nstack",\&op_nstack,0,'"Nullary" Number of depth of the stack');
X setsysfunc("sysver",\&op_version,0,'"Nullary" System version number.');
-setsysfunc("untype",\&op_untype,0,'"Nallary" Make untype');
-setsysfunc("null_array",\&op_null_array,0,'"Nallary" Make null array');
+setsysfunc("untype",\&op_untype,0,'"Nullary" Make untype');
+setsysfunc("null_array",\&op_null_array,0,'"Nullary" Make null array');
X setsysfunc("undefined_value",\&op_undefined_value,0,
- '"Nallary" Make undefined value');
+ '"Nullary" Make undefined value');
X
X
X ###############################
@@ -1741,7 +1776,7 @@
X $d->{flag} = 1;
X push @{$varstack},$d;
X }
-}
+} # end of modify_stack
X
X ##################
X ### Identifier ###
@@ -1840,8 +1875,32 @@
X push @DO_NOT_REMOVE_ID,$name if $name =~ /($PTN_ID)/o;
X }
X
-sub setsysbin ( $$$$ ) {
- my ($name,$func,$prior,$comment) = @_;
+sub setsysunary( $$$$;$ ) {
+ my ($name,$func,$arrayex,$comment,$ref) = @_;
+ my $v = setID($name);
+ unless (ref $v) {
+ die "!!BUG!! setsysunary: \"$name\" : doubly defined: ";
+ }
+ if (defined $ref) {
+ die "!!BUG!! setsysunary: length($ref)!=1: "
+ unless length($ref) == 1;
+ } else {
+ $ref = "."; # Default
+ }
+
+ $v->{type} = "F";
+ $v->{const} = "C";
+ $v->{value} = \&$func;
+ $v->{narg} = 1;
+ $v->{arrayex} = $arrayex;
+ $v->{name} = "$name";
+ $v->{comment} = $comment if $comment;
+ $v->{ref} = $ref;
+ push @DO_NOT_REMOVE_ID,$name if $name =~ /($PTN_ID)/o;
+}
+
+sub setsysbin ( $$$$$ ) {
+ my ($name,$func,$prior,$arrayex,$comment) = @_;
X my $v = setID($name);
X unless (ref $v) {
X die "!!BUG!! setsysbin: \"$name\" : doubly defined: ";
@@ -1851,6 +1910,7 @@
X $v->{value} = \&$func;
X $v->{narg} = 2;
X $v->{prior} = $prior;
+ $v->{arrayex} = $arrayex;
X $v->{name} = "$name";
X $v->{comment} = $comment if $comment;
X $v->{ref} = "..";
@@ -1872,9 +1932,14 @@
X my $t = $v->{type};
X my $var = ($v->{const} eq 'C' ? "==" : "=");
X if ($t eq 'B') {
- print "$v->{name} : (Binary. Priority=$v->{prior})\n";
+ print "$v->{name} : (Binary. Priority=$v->{prior}.";
+ print " Array expandable." if $v->{arrayex};
+ print ")\n";
X } elsif ($t eq 'F') {
- print "$v->{name} ($v->{narg})\n";
+ print "$v->{name} ($v->{narg})";
+ print " array expandable unary."
+ if defined $v->{arrayex} and $v->{arrayex};
+ print "\n";
X } elsif ($t eq 'N') {
X print "$v->{name} $var ",Stringify($v),"\n";
X } elsif ($t eq 'S') {
@@ -1903,9 +1968,15 @@
X unless $f->{type} eq 'F' or $f->{type} eq 'B';
X if (ref($f->{value})eq 'CODE') {
X if ($f->{type} eq 'B') {
- print "\"$id\" is system binary operator. Priority = $f->{prior}.\n";
+ print "\"$id\" is system binary operator. Priority = $f->{prior}.";
+ print " Array expandable." if $f->{arrayex};
+ print "\n";
X } else {
- print "\"$id\" is system function. Number of parameters = $f->{narg}.\n";
+ if (defined $f->{arrayex} and $f->{arrayex}) {
+ print "\"$id\" is system array expandable unary operator.\n";
+ } else {
+ print "\"$id\" is system function. Number of parameters = $f->{narg}.\n";
+ }
X }
X } else {
X print "$f->{value}\n";
@@ -1920,7 +1991,40 @@
X $s =~ s/([\+\-$@.?^\(\)\{\}\[\]\":|&])/\\$1/g;
X $s =~ s/\*/.*/g;
X my $id;
- if ($s =~ /^binary$/i) {
+ if ($s =~ /^Nullary$/i) {
+ print "\nDefined nullary operators are;\n",
+ "------------------------------\n";
+ my @un;
+ foreach $id (sort keys(%globalID),sort keys(%localID)) {
+ $v = getID($id,"Do not remove reference");
+ if ($v->{comment} =~ /^\"Nullary\"/i) {
+ print "$v->{name} :\n";
+ my $cmt = $v->{comment};
+ $cmt = "" unless defined $cmt;
+ $cmt =~ s/^\".*?\"\s*//;
+ print " $cmt\n";
+ }
+ }
+ } elsif ($s =~ /^Unary$/i) {
+ print "\n";
+ print "Defined unary operators are;\n",
+ "----------------------------\n";
+ my @un;
+ foreach $id (sort keys(%globalID),sort keys(%localID)) {
+ $v = getID($id,"Do not remove reference");
+ if ($v->{comment} =~ /^\"Unary\"/i) {
+ print "$v->{name} :";
+ print " (Array expandable)" if $v->{arrayex};
+ print "\n";
+ my $cmt = $v->{comment};
+ $cmt = "" unless defined $cmt;
+ $cmt =~ s/^\".*?\"\s*//;
+ print " $cmt\n";
+ }
+ }
+
+ } elsif ($s =~ /^Binary$/i) {
+ print "\n";
X print "Defined binary operators are;\n",
X "-----------------------------\n";
X my @bin;
@@ -1931,16 +2035,18 @@
X }
X }
X foreach $v (sort { $a->{prior} <=> $b->{prior} } @bin) {
- print "$v->{name} :\tpriority=$v->{prior}\n";
+ print "$v->{name} :\tPriority=$v->{prior}.";
+ print " Array expandable." if $v->{arrayex};
+ print "\n";
X if (defined $v->{comment}) {
X my $cmt = $v->{comment};
X $cmt =~ s/^\".*?\"\s*//;
X print "\t $cmt\n";
X }
X }
- } elsif ($s =~ /^constant$/i) {
- print "Defined constants are;\n",
- "----------------------\n";
+ } elsif ($s =~ /^Constant$/i) {
+ print "\nDefined constants are;\n",
+ "----------------------\n";
X foreach $id (sort keys(%globalID),sort keys(%localID)) {
X $v = getID($id,"Do not remove reference");
X my $t = $v->{type};
@@ -1952,6 +2058,40 @@
X print "$v->{name} == $dt\n\t$cmt\n";
X }
X }
+ } elsif ($s =~ /^array(_?|\s+)expandable$|^arrayex$/i) {
+ my (@un,@bin);
+ foreach $id (sort keys(%globalID),sort keys(%localID)) {
+ $v = getID($id,"Do not remove reference");
+ if ($v->{arrayex}) {
+ if ($v->{type} eq 'B') {
+ push @bin,$v;
+ } else {
+ push @un,$v;
+ }
+ }
+ }
+ print "\n";
+ print "Defined array expandable unary operators are;\n",
+ "---------------------------------------------\n";
+ foreach $v (@un) {
+ print "$v->{name} :\n";
+ if (defined $v->{comment}) {
+ my $cmt = $v->{comment};
+ $cmt =~ s/^\".*?\"\s*//;
+ print "\t $cmt\n";
+ }
+ }
+ print "\n";
+ print "Defined array expandable binary operators are;\n",
+ "----------------------------------------------\n";
+ foreach $v (sort { $a->{prior} <=> $b->{prior} } @bin) {
+ print "$v->{name} :\tPriority=$v->{prior}.\n";
+ if (defined $v->{comment}) {
+ my $cmt = $v->{comment};
+ $cmt =~ s/^\".*?\"\s*//;
+ print "\t $cmt\n";
+ }
+ }
X } else {
X foreach $id (sort keys(%globalID),sort keys(%localID)) {
X $v = getID($id,"Do not remove reference");
@@ -1960,9 +2100,14 @@
X my $t = $v->{type};
X my $var = ($v->{const} eq 'C' ? "==" : "=");
X if ($t eq 'B') {
- print "$v->{name} : (Binary. Priority=$v->{prior})\n";
+ print "$v->{name} : (Binary. Priority=$v->{prior}.";
+ print " Array expandable." if $v->{arrayex};
+ print ")\n";
X } elsif ($t eq 'F') {
- print "$v->{name} ($v->{narg})\n";
+ print "$v->{name} ($v->{narg})";
+ print " array expandable unary."
+ if defined $v->{arrayex} and $v->{arrayex};
+ print "\n";
X } elsif ($t eq 'N') {
X print "$v->{name} $var ",Stringify($v),"\n";
X } elsif ($t eq 'S') {
@@ -2059,17 +2204,17 @@
X use strict qw(vars subs refs);
X --$Fnumber;
X $_ = "";
-}
+} # end of op_include
X
X setsysfunc("pc",\&op_print_comment,1,
X 'Print comment of function,variable or constant.');
X setsysfunc("pd",\&op_print_function_definition,1,
X 'Print function definition.');
X setsysfunc("apropos",\&op_apropos,1,'Search variables and functions.');
-setsysfunc("quit",\&op_quit,0,"Quit");
-setsysfunc("exit",\&op_exit,1,"Exit with return code");
-setsysfunc("die",\&op_die,1,"Die. Terminate execution with message.");
-setsysfunc("include",\&op_include,1,"Include file.");
+setsysfunc("quit",\&op_quit,0,'Quit');
+setsysfunc("exit",\&op_exit,1,'Exit with return code');
+setsysfunc("die",\&op_die,1,'Die. Terminate execution with message.');
+setsysfunc("include",\&op_include,1,'Include file.');
X
X ###############
X ## for debug ##
@@ -2135,20 +2280,23 @@
X return $c;
X }
X
+sub flush_un_stack ();
+
X sub flush_cmdln () {
X @cmdline = ();
X ($cmdline,$cmdsrc,$cmdbgn,$cmdpnt) = ("","",0,0);
+ flush_un_stack;
X }
X
-my %COLOUR = ( red => "\x1b[31m",
- green => "\x1b[32m",
- yellow => "\x1b[33m",
- blue => "\x1b[34m",
- violet => "\x1b[35m",
- light_blue => "\x1b[36m",
- white => "\x1b[37m"
+my %COLOUR = ( red => "\x1b\[31m",
+ green => "\x1b\[32m",
+ yellow => "\x1b\[33m",
+ blue => "\x1b\[34m",
+ violet => "\x1b\[35m",
+ light_blue => "\x1b\[36m",
+ white => "\x1b\[37m"
X );
-my $NORMAL = "\x1b[m";
+my $NORMAL = "\x1b\[m";
X
X my $MONO_ERR_BGN = " >>>";
X my $MONO_ERR_END = "<<< ";
@@ -2232,7 +2380,7 @@
X print STDERR "\n";
X restore_vstack() while (@saved_varstack);
X flush_cmdln;
-}
+} # end of trace_error
X
X sub DIE ( $;@ ) {
X my ($mes,@vars) = @_;
@@ -2336,7 +2484,7 @@
X last;
X } # end of while
X check_terminator_for_command("if");
-}
+} # end of c_if
X
X sub c_while () {
X my $saved_line = $_;
@@ -2447,18 +2595,22 @@
X last;
X }
X }
-}
+} # end of c_for
X
X sub c_def () { # Function definition
X ### Define variable,function ###
X $cmdpnt += length($&) if s/^\s+//;
- if (s/^\(\s*($PTN_ID)\s*\)\s*($PTN_ID)\s*\(\s*($PTN_ID)\s*\)\s*(\d*)\s*=\s*\{//o) {
+ if (s/^\(\s*($PTN_ID)\s*\)\s*($PTN_ID)\s*\(\s*($PTN_ID)\s*\)\s*(\d*)\s*($PTN_ARRAYEX)?\s*=\s*\{//o) {
X ### def_binary ###
X $cmdpnt += length $&;
+ if ($comment =~ /^\"Unary\"/i) {
+ die "def: Hiden comment \"Unary\" should be used only in unary operator.\n";
+ }
X my $left = $1;
X my $binid = $2;
X my $right = $3;
X my $priority = $4;
+ my $arrayex = $5;
X my $def = $&;
X $def =~ s/\s+//g;
X $def =~ s/\{//;
@@ -2484,6 +2636,7 @@
X @{$binop->{args}} = ($left,$right);
X $binop->{narg} = 2;
X $binop->{prior} = ($priority ? $priority : 9999); # default: lowest
+ $binop->{arrayex} = (defined $arrayex ? 1 : 0);
X $binop->{name} = $binid;
X } elsif (s/^($PTN_ID)\s*\(//o) {
X ### def function, operator ###
@@ -2496,7 +2649,7 @@
X unless $_;
X $cmdpnt += length $& if s/^\s+//;
X $cmdbgn = $cmdpnt;
- if (s/^($PTN_REF)?($PTN_ID)\s*//o) {
+ if (s/^($PTN_REF)?\s*($PTN_ID)\s*//o) {
X my $ref = $1;
X my $id = $2;
X $cmdpnt += length $&;
@@ -2521,6 +2674,19 @@
X }
X }
X } # end of while
+ if ($comment =~ /^\"Nullary\"/i and @param != 0) {
+ die "def: Hiden comment \"Nullary\" should be used only in nullary operator.\n";
+ }
+ if ($comment =~ /^\"Unary\"/i and @param != 1) {
+ die "def: Hiden comment \"Unary\" should be used only in unary operator.\n";
+ }
+ my $arrayex = 0;
+ if (s/^($PTN_ARRAYEX)\s*//) {
+ $cmdpnt += length $&;
+ $arrayex = 1;
+ die "def: Array expansion should be used for unary or binary operator.\n"
+ unless @param == 1;
+ }
X unless (s/^=\s*\{//) {
X die "def: Format error.\n";
X }
@@ -2536,16 +2702,21 @@
X $func =~ s/\n/ /g;
X my $def = join(',',@param);
X $fop->{comment} = $comment if $comment;
- $fop->{value} = "$id(" . join(',',@param) . ")=$func";
+ $fop->{value} = "$id(" . join(',',@param) . ")" .
+ ($arrayex ? "ax" : "") . "=$func";
X $fop->{type} = 'F';
X $fop->{const} = 'C';
X @{$fop->{args}} = @param;
X $fop->{narg} = scalar @param;
+ $fop->{arrayex} = $arrayex;
X $fop->{name} = $id;
X } elsif (s/^($PTN_ID)\s*(={0,2})\s*//o) { # variable/constant definition
X $cmdpnt += length($&);
X my $id = $1;
X my $as = $2;
+ if ($comment =~ /^\"Unary\"/i) {
+ die "def: Hiden comment \"Unary\" should be used only in unary operator.\n";
+ }
X my $v = setID($id);
X die "def: \"$id\" is declared already.\n" unless ref $v;
X if ($as) {
@@ -2562,7 +2733,7 @@
X die "def: Bad def format: ";
X }
X check_terminator_for_command("def");
-}
+} # end of c_def
X
X sub c_assign () {
X my $v = set_varcon();
@@ -2682,7 +2853,7 @@
X }
X restore_vstack();
X ++$nexpr;
- } elsif (/^($PTN_REF)\s*($PTN_ID)\s*/o) {
+ } elsif (/^($PTN_REF)\s*($PTN_ID|$PTN_BINARY|$PTN_UNARY)\s*/o) {
X my $r = get_varcon();
X unless (/^[,\)]/) {
X $cmdbgn = $cmdpnt;
@@ -2761,7 +2932,7 @@
X }
X $cmdbgn = $first_paren;
X die "paren: No right parenthesis found.\n";
-}
+} # end of paren
X
X sub term ( ;$ ) { # return code: 1->term gotten, 0->no term, ref->operator
X # print "#",__LINE__,"# term: \$_=<<$_>>\n\tcmdpnt=$cmdpnt\n" if $DEBUG;
@@ -2792,6 +2963,11 @@
X $un = $ID_UN_MINUS if $un =~ /\-/;
X push_un [$un,$prepnt,$cmdpnt];
X next;
+ } elsif (s/^($PTN_REF)\s*($PTN_BINARY|$PTN_UNARY)//o) {
+ $cmdpnt += length($&);
+ pushvstack setref(getID($2));
+ $cmdbgn = $cmdpnt;
+ last;
X } elsif (/^($PTN_REF)?\s*($PTN_ID)/o) {
X # if ($1) {
X # ++$cmdpnt;
@@ -2959,12 +3135,12 @@
X $cmdpnt = $sv_pnt;
X pop_un_stack;
X # print "#",__LINE__,"# term: \$_=<<$_>>\n\tcmdpnt=$cmdpnt\n" if $DEBUG;
- return 1;
+ return 1; # Term detected
X } else {
X die "term: Stack broken, or Too many arguments for unary operator.\n";
X }
X die "!!BUG!! term: Never.: ";
-}
+} # end of term
X
X
X sub expression ( ;$ ) { # evaluate expression
@@ -3078,7 +3254,7 @@
X $cmdpnt = $svpnt;
X $cmdbgn = $saved_bgn;
X return;
-}
+} # end of expression
X
X sub skip_brace () {
X my $saved_bgn = $cmdbgn;
@@ -3321,7 +3497,7 @@
X # print "#",__LINE__,"# set_varcon: \$_=<<$_>>\n\tcmdpnt=$cmdpnt\n" if $DEBUG;
X my $skip = shift;
X die "!!BUG!! set_varcon: Missing ID: "
- unless s/^($PTN_REF)?\s*($PTN_ID)\s*//o;
+ unless s/^($PTN_REF)?\s*($PTN_ID|$PTN_BINARY|$PTN_UNARY)\s*//o;
X $cmdpnt += length($&);
X # print "#",__LINE__,"# set_varcon: \$_=<<$_>>\n\tcmdpnt=$cmdpnt\n" if $DEBUG;
X my $ref = $1;
@@ -3611,7 +3787,7 @@
X return;
X } elsif (/^($PTN_REF)?\s*($PTN_ID)\s*($PTN_BRACKET)*($PTN_ENDOFCOMMAND)/o){
X ##### Bare ID or array element #####
- my $ref = $1;
+ print "#",__LINE__,"# Bare ID or array element: \$_=<<$_>>\n" if $DEBUG;
X my $op = get_varcon();
X if ($op->{type} eq 'F' or $op->{type} eq 'B') {
X die "\"$op->{name}\": Too less stack.\n"
@@ -3702,7 +3878,7 @@
X expression();
X modify_stack();
X }
-}
+} # end of command
X
X sub check_terminator_for_command ( $ ) {
X my $comment = shift;
diff -urN Cafe_2.2-pre.1/lib/define.cafe Cafe_2.2/lib/define.cafe
--- Cafe_2.2-pre.1/lib/define.cafe 2004-01-31 11:49:16.000000000 +0900
+++ Cafe_2.2/lib/define.cafe 2004-12-01 18:22:16.000000000 +0900
@@ -1,4 +1,4 @@
-# define.cafe : Cafe auxiliary system definition file (Ver.2.1)
+# define.cafe : Cafe auxiliary system definition file (Ver.2.2)
X #
X
X # Author:
@@ -14,18 +14,14 @@
X # 11 May 2000 Ver.0.1
X # 30 May 2000 Ver.0.2
X # 18 Aug.2000 Ver.0.3
-# 4 Mar.2003 Ver.1.0 (Released)
-# 20 Mar.2003 Ver.1.1 (Released)
-# 15 Apr.2003 Ver.2.0-pre.1 (Pre-released)
-# 5 May 2003 Ver.2.0-pre.2 (Pre-released)
-# 15 May 2003 Ver.2.0 (Released)
-# 22 May 2003 Ver.2.0-patch.1 (Released)
-# 24 Dec.2003 Ver.2.1-pre.1 (Pre-released)
-# 3 Jan.2004 Ver.2.1 (Released)
-# 31 Jan.2004 Ver.2.1-patch.1 (Released)
+# 4 Mar.2003 Ver.1.0
+# 20 Mar.2003 Ver.1.1
+# 15 May 2003 Ver.2.0
+# 3 Jan.2004 Ver.2.1
+# 1 Dec.2004 Ver.2.2
X #
X
-def DEFVER=="2.1-patch.1"; # Version number of define.cafe
+def DEFVER=="2.2"; # Version number of define.cafe
X
X def Version() = { # Print version \
X print "\tCafe system : Version $(sysver)\n"; \
@@ -35,10 +31,10 @@
X # eval DEFVER # 1.9991 (pre-release) or 2.001 (patched) for example
X # eval sysver # same as above
X
-def pre($p) = {+0.001(1-$p)} \
+def pre($p) ax = {+0.001(1-$p)} \
X # Pre-release version \
X # $p : pre-lelease level (.1 to .9 or .01 to .99)
-def patch($p) = {-0.01$p} \
+def patch($p) ax = {-0.01$p} \
X # Patched version \
X # $p : patch level (.1 to .9 or .01 to .99)
X
@@ -61,15 +57,15 @@
X def inf == 1e9999999999 # Infinitive number
X def nan == inf - inf # Non arithmetic number
X
-def ($a)and($b)1000={$a & $b} # Logical AND (same as "&")
-def ($a)or($b) 1010={$a | $b} # Logical OR (same as "|")
-def ($a)xor($b)1020={$a & !$b | !$a & $b} # Logical EXCLUSIVE OR
-def not($a)={!$a} # "Unary" Logical negation (same as "!")
+def ($a)and($b)1000 ax = {$a & $b} # Logical AND (same as "&")
+def ($a)or($b) 1010 ax = {$a | $b} # Logical OR (same as "|")
+def ($a)xor($b)1020 ax = {$a & !$b | !$a & $b} # Logical EXCLUSIVE OR
+def not($a) ax = {!$a} # "Unary" Logical negation (same as "!")
X
X def copy($n) = {$n=:} # Copy stack[$n]
X def dup($a) = {push $a; $a} # Duplicate the last element on stack
X def insert($n) = {$x=pop; $n +: $x} \
-# # Insert last data on stack into n-th data on stack
+ # Insert last data on stack into n-th data on stack
X def extract($n) = {$n -:+ } # Extract n-th data on stack
X def swap(@$a) = {stack <=> $a} # Swap contents of stack and array $a
X def shrink() = {$x<=>stack; clear; $x} \
@@ -115,76 +111,79 @@
X ### Mathmatical Functions ###
X ###############################
X #
-def neg($x) = {-$x} # Negate (Unary minus)
-def inv($x) = {1/$x} # "Unary" Inverse (Reciprocal)
-def conj($x) = {~$x} # "Unary" Complex conjugate
-def ($c)mod($r) 150 = {$c - floor($c/$r)$r} \
- # Modulo (generalized for complex number)
+def pos($x) ax = {+$x} # "Unary" Positive (Unary plus)
+def neg($x) ax = {-$x} # "Unary" Negate (Unary minus)
+def inv($x) ax = {1/$x} # "Unary" Inverse (Reciprocal)
+def conj($x) ax = {~$x} # "Unary" Complex conjugate
+def ($c)mod($r) 150 ax = {$c - floor($c/$r)$r} \
+ # Modulo (generalized for complex number)
X
-def rfloor($r) = { if(Im($r)!=0){ \
- # "Unary" Highest integer <= $r (Limited real) \
+def rfloor($r) ax = { if(Im($r)!=0){ \
+ # "Unary" Highest integer <= $r (Limited real) \
X die "rfloor can execute only real number." \
X } else {$i=int($r)-1; $i+int($r-$i)}}
-def floor($c) = {rfloor(Re($c))+j rfloor(Im($c))} \
+def floor($c) ax = {rfloor(Re($c))+j rfloor(Im($c))} \
X # "Unary" Highest integer <= $c
-def ceil($c) = {-floor(-$c)} \
+def ceil($c) ax = {-floor(-$c)} \
X # "Unary" Lowest integer >= $c
-def round($c) = {floor($c+0.5+0.5j)} \
+def round($c) ax = {floor($c+0.5+0.5j)} \
X # "Unary" Round to integer
X def fround($c,$d) = {round($c/10^$d)*10^$d} \
X # Floating Round
X
-def ($a)max($b) 250 = {($a>$b ? $a : $b)} # Maximum
-def ($a)min($b) 250 = {($a<$b ? $a : $b)} # Minimum
+def ($a)max($b) 250 ax = {($a>$b ? $a : $b)} # Maximum
+def ($a)min($b) 250 ax = {($a<$b ? $a : $b)} # Minimum
X
-def abs($x) = {sqrt(Re($x)*Re($x) + Im($x)*Im($x))} # "Unary" Absolute value
-def rabs($r) = { ($r>=0 ? $r : -$r) } # "Unary" Absolute real value
-def sqabs($x) = {Re($x)*Re($x) + Im($x)*Im($x)} \
+def abs($x) ax = {sqrt(Re($x)*Re($x) + Im($x)*Im($x))} # "Unary" Absolute value
+def rabs($r) ax = {($r>=0 ? $r : -$r)} # "Unary" Absolute real value
+def sqabs($x) ax = {Re($x)*Re($x) + Im($x)*Im($x)} \
X # "Unary" Squared absolute value
-def sqrt($x) = {$x^0.5} # "Unary" Square root
-def d2r($x) = {pi($x/180)} # "Unary" Degree to Radian
-def r2d($x) = {180$x/pi} # "Unary" Radian to Degree
-def arg($x) = {atan2(Im($x),Re($x))} # "Unary" argument of complex $x
-def angle($x) = {arg($x)} # "Unary" angle of complex $x
-def sin($x) = {(exp(j$x)-exp(-j$x))/2j} # "Unary" Trigonometric sine
-def cos($x) = {(exp(j$x)+exp(-j$x))/2} # "Unary" Trigonometric cosine
-def tan($x) = {$p=exp(j$x); $n=exp(-j$x); ($p-$n)/($p+$n)j } \
+def sqrt($x) ax = {$x^0.5} # "Unary" Square root
+def d2r($x) ax = {pi($x/180)} # "Unary" Degree to Radian
+def r2d($x) ax = {180$x/pi} # "Unary" Radian to Degree
+def arg($x) ax = {atan2(Im($x),Re($x))} # "Unary" argument of complex $x
+def angle($x) ax = {arg($x)} # "Unary" angle of complex $x
+def sin($x) ax = {(exp(j$x)-exp(-j$x))/2j} # "Unary" Trigonometric sine
+def cos($x) ax = {(exp(j$x)+exp(-j$x))/2} # "Unary" Trigonometric cosine
+def tan($x) ax = {$p=exp(j$x); $n=exp(-j$x); ($p-$n)/($p+$n)j } \
X # "Unary" Trigonometric tangent
-def sec($x) = {1/cos($x)} # "Unary" Trigonometric secant
-def cosec($x) = {1/sin($x)} # "Unary" Trigonometric cosecant
-def cotan($x) = {cos($x)/sin($x)} # "Unary" Trigonometric cotangent
-def asin($x) = {-j log(j$x+sqrt(1-$x$x))} # "Unary" Trigonometric arc sine
-#def acos($x) = {-j log($x+sqrt($x$x-1))} # "Unary" Trigonometric arc cosine
-def acos($x) = {-j log($x+sqrt($x$x-1)); if(Im$x!=0){neg}} \
+def sec($x) ax = {1/cos($x)} # "Unary" Trigonometric secant
+def cosec($x) ax = {1/sin($x)} # "Unary" Trigonometric cosecant
+def cotan($x) ax = {cos($x)/sin($x)} # "Unary" Trigonometric cotangent
+def asin($x) ax = {-j log(j$x+sqrt(1-$x$x))} # "Unary" Trigonometric arc sine
+#def acos($x) ax = {-j log($x+sqrt($x$x-1))} # "Unary" Trigonometric arc cosine
+def acos($x) ax = {-j log($x+sqrt($x$x-1)); if(Im$x!=0){neg}} \
X # "Unary" Trigonometric arc cosine
-def atan($x) = {0.5j log((j+$x)/(j-$x))} # "Unary" Trigonometric arc tangent
-def asec($x) = {acos(1/$x)} # "Unary" Trigonometric arc secant
-def acosec($x) = {asin(1/$x)} # "Unary" Trigonometric arc cosecant
-def acotan($x) = {atan(1/$x)} # "Unary" Trigonometric arc cotangent
-def sinh($x) = {(exp($x) - exp(-$x))/2} # "Unary" Hyperbolic sine
-def cosh($x) = {(exp($x) + exp(-$x))/2} # "Unary" Hyperbolic cosine
-def tanh($x) = {sinh($x) / cosh($x)} # "Unary" Hyperbolic tangent
-def sech($x) = {1/cosh($x)} # "Unary" Hyperbolic secant
-def cosech($x) = {1/sinh($x)} # "Unary" Hyperbolic cosecant
-def cotanh($x) = {cosh($x)/sinh($x)} # "Unary" Hyperbolic cotangent
-def asinh($x) = {log($x+sqrt($x*$x+1))} # "Unary" Hyperbolic arc sine
-def acosh($x) = {log($x+sqrt($x*$x-1))} # "Unary" Hyperbolic arc cosine
-def atanh($x) = {0.5 log((1+$x)/(1-$x))} # "Unary" Hyperbolic arc tangent
-def asech($x) = {acosh(1/$x)} # "Unary" Hyperbolic arc secant
-def acosech($x) = {asinh(1/$x)} # "Unary" Hyperbolic arc cosecant
-def acotanh($x) = {0.5 log(($x+1)/($x-1))} # "Unary" Hyperbolic arc cotangent
-def atan2($y,$x) = {((Im($y)==0 and Im($x)==0) ? ratan2($y,$x) : atan($y/$x))}
-def exp2($x) = {2^$x} # "Unary" Exponent (base 2)
-def exp10($x) = {10^$x} # "Unary" Exponent (base 10)
-def log2($x) = {log($x)/log(2)} # "Unary" Logarithm (base 2)
-def log10($x) = {log($x)/log(10)} # "Unary" Logarithm (base 10)
-def inverf($x) = { # "Unary" Inverse Error Function \
+def atan($x) ax = {0.5j log((j+$x)/(j-$x))} # "Unary" Trigonometric arc tangent
+def asec($x) ax = {acos(1/$x)} # "Unary" Trigonometric arc secant
+def acosec($x) ax = {asin(1/$x)} # "Unary" Trigonometric arc cosecant
+def acotan($x) ax = {atan(1/$x)} # "Unary" Trigonometric arc cotangent
+def sinh($x) ax = {(exp($x) - exp(-$x))/2} # "Unary" Hyperbolic sine
+def cosh($x) ax = {(exp($x) + exp(-$x))/2} # "Unary" Hyperbolic cosine
+def tanh($x) ax = {sinh($x) / cosh($x)} # "Unary" Hyperbolic tangent
+def sech($x) ax = {1/cosh($x)} # "Unary" Hyperbolic secant
+def cosech($x) ax = {1/sinh($x)} # "Unary" Hyperbolic cosecant
+def cotanh($x) ax = {cosh($x)/sinh($x)} # "Unary" Hyperbolic cotangent
+def asinh($x) ax = {log($x+sqrt($x*$x+1))} # "Unary" Hyperbolic arc sine
+def acosh($x) ax = {log($x+sqrt($x*$x-1))} # "Unary" Hyperbolic arc cosine
+def atanh($x) ax = {0.5 log((1+$x)/(1-$x))} # "Unary" Hyperbolic arc tangent
+def asech($x) ax = {acosh(1/$x)} # "Unary" Hyperbolic arc secant
+def acosech($x) ax = {asinh(1/$x)} # "Unary" Hyperbolic arc cosecant
+def acotanh($x) ax = {0.5 log(($x+1)/($x-1))} \
+ # "Unary" Hyperbolic arc cotangent
+def atan2($y,$x) = {((Im($y)==0 & Im($x)==0) ? ratan2($y,$x) : atan($y/$x))} \
+ # Trigonometric arc tangent of two variables
+def exp2($x) ax = {2^$x} # "Unary" Exponent (base 2)
+def exp10($x) ax = {10^$x} # "Unary" Exponent (base 10)
+def log2($x) ax = {log($x)/log(2)} # "Unary" Logarithm (base 2)
+def log10($x) ax = {log($x)/log(10)} # "Unary" Logarithm (base 10)
+def inverf($x) ax = { # "Unary" Inverse Error Function \
X ($x>0.5? -inverf(1-$x) : \
X ({$b=-log($x*$x); $a=sqrt($b); \
X $a-(2.515517+0.802853$a+0.010328$b) / \
X (1+1.432788$a+0.189269$b+0.001308$a*$b)}) \
X )}
-def sinc($x)={(abs($x)>0.1 ? sin($x)/$x : 1-$x^2/6+$x^4/120-$x^6/5024)} \
+def sinc($x) ax = {(abs($x)>0.1 ? sin($x)/$x : 1-$x^2/6+$x^4/120-$x^6/5024)} \
X # "Unary" Accuracy: error < 1e-12 for x=0.1
X
X ##################################################
@@ -244,25 +243,25 @@
X ### Unit Conversion ###
X #########################
X #
-def j2c($x) = {$x / 4.18605} # "Unary" joule(J) -> calorie(cal)
-def c2j($x) = {4.18605 $x} # "Unary" calorie(cal) -> joule(J)
-def c2k($t) = {273.15 + $t} # "Unary" Celsius(C) -> Kelvin(K)
-def k2c($t) = {$t - 273.15} # "Unary" Kelvin(K) -> Celsius(C)
-def ps2kw($hp) = {0.7355 $hp} # "Unary" 1PS=0.7355kW
+def j2c($x) ax = {$x / 4.18605} # "Unary" joule(J) -> calorie(cal)
+def c2j($x) ax = {4.18605 $x} # "Unary" calorie(cal) -> joule(J)
+def c2k($t) ax = {273.15 + $t} # "Unary" Celsius(C) -> Kelvin(K)
+def k2c($t) ax = {$t - 273.15} # "Unary" Kelvin(K) -> Celsius(C)
+def ps2kw($hp) ax = {0.7355 $hp} # "Unary" 1PS=0.7355kW
X
X ############################################################
X ### Era Conversion (Japanese Gengoh <-> Christian Era) ###
X ############################################################
X #
-def meiji($year) = {($year<=45? 1:j) (1867+$year)} \
+def meiji($year) ax = {($year<=45? 1:j) (1867+$year)} \
X # "Unary" meiji -> seireki
-def taishoh($year) = {($year<=15? 1:j) (1911+$year)} \
+def taishoh($year) ax = {($year<=15? 1:j) (1911+$year)} \
X # "Unary" taishoh -> seireki
-def shohwa($year) = {($year<=64? 1:j) (1925+$year)} \
+def shohwa($year) ax = {($year<=64? 1:j) (1925+$year)} \
X # "Unary" shohwa -> seireki
-def heisei($year) = {1988 + $year} \
+def heisei($year) ax = {1988 + $year} \
X # "Unary" heisei -> seireki
-def seireki($year) = { # "Unary" seireki -> wago \
+def seireki($year) ax = { # "Unary" seireki -> wago \
X ($year<=1911 ? "meiji $($year-1867)": \
X ($year<=1925 ? "taishoh $($year-1911)" : \
X ($year<=1988 ? "shohwa $($year-1925)" : \
@@ -286,7 +285,7 @@
X def e0 == 1/(u0 * c^2) # Dielectric Permittivity of Vacuum (F/m)
X def ec == 1.60247733e-19 # Elementary Charge (C)
X
-def Sigma_material($m) = { # "Unary" \
+def Sigma_material($m) ax = { # "Unary" \
X # Translate material name to conductivity. \
X # Conductivity of Material (sigma: S/m) \
X # $m: Chemical Symbol of Material or Conductivity(sigma: S/m) \
@@ -316,10 +315,10 @@
X ### for Electronics ###
X #########################
X #
-def db10($x)={10*log10($x)} # "Unary" Decibel(Power)
-def db20($x)={20*log10($x)} # "Unary" Decibel(Amplitude)
-def dBm($power)={db10($power)+30} # "Unary" Decibel of Power (0dBm=1mW)
-def dbp($x)={db10(sqabs($x))} # "Unary" Decibel(Complex amplitude)
+def db10($x) ax = {10*log10($x)} # "Unary" Decibel(Power)
+def db20($x) ax = {20*log10($x)} # "Unary" Decibel(Amplitude)
+def dBm($power) ax = {db10($power)+30} # "Unary" Decibel of Power (0dBm=1mW)
+def dbp($x) ax = {db10(sqabs($x))} # "Unary" Decibel(Complex amplitude)
X
X def skin_depth($f,$u,$sigma)={sqrt(2/(2pi $f $u Sigma_material($sigma)))} \
X # Skin Depth (m) \
@@ -327,7 +326,9 @@
X # u: Permeability (H/m, Note: u0 if vacuume) \
X # sigma: Conductivity(S/m) or Chemical Symbol of Material
X
-def skin_depth_Cu($f)={skin_depth($f,u0,5.8e7)} # Skin Depth of Copper (m)
+def skin_depth_Cu($f) ax = {skin_depth($f,u0,5.8e7)} \
+ # "Unary" Skin Depth of Copper (m)
+ # f: Frequency (Hz)
X
X def DC_resistance($d,$sigma)={1/(Sigma_material($sigma) pi($d/2)^2)} \
X # DC Resistance of Electorical Wire in a unit length (ohm/m) \
@@ -349,8 +350,8 @@
X # len: Length of the coil (m) \
X # N: Turns
X
-def QofZ($z) ={abs(Im($z)) / abs(Re($z))} # Q of Z
-def LossofZ($z)={abs(Re($z)) / abs(Im($z))} # Loss of Z
+def QofZ($z) ax = {abs(Im($z)) / abs(Re($z))} # Q of Z
+def LossofZ($z) ax = {abs(Re($z)) / abs(Im($z))} # Loss of Z
X
X # Transmission Line
X #
diff -urN Cafe_2.2-pre.1/lib/diagnosis.cafe Cafe_2.2/lib/diagnosis.cafe
--- Cafe_2.2-pre.1/lib/diagnosis.cafe 2004-01-03 17:01:24.000000000 +0900
+++ Cafe_2.2/lib/diagnosis.cafe 2004-12-01 18:22:55.000000000 +0900
@@ -16,17 +16,14 @@
X # 11 May 2000 Ver.0.1
X # 30 May 2000 Ver.0.2
X # 18 Aug.2000 Ver.0.3
-# 4 Mar.2003 Ver.1.0 (Released)
-# 20 Mar.2003 Ver.1.1 (Released)
-# 15 Apr.2003 Ver.2.0-pre.1 (Pre-released)
-# 5 May 2003 Ver.2.0-pre.2 (Pre-released)
-# 15 May 2003 Ver.2.0 (Released)
-# 22 May 2003 Ver.2.0-patch.1 (Released)
-# 24 Dec.2003 Ver.2.1-pre.1 (Pre-released)
-# 3 Jan.2004 Ver.2.1 (Released)
+# 4 Mar.2003 Ver.1.0
+# 20 Mar.2003 Ver.1.1
+# 15 May 2003 Ver.2.0
+# 3 Jan.2004 Ver.2.1
+# 1 Dec.2004 Ver.2.2
X #
X
-$REQUIRED_VERSION = "2.1"
+$REQUIRED_VERSION = "2.2"
X print "\nThis diagnostic script is for cafe version $REQUIRED_VERSION or later.\n"
X Version
X print "\n"
@@ -446,6 +443,27 @@
X if($wd[1] ne 'xyz'){die "Error: word: \$wd[1] ne 'xyz'."}
X if($wd[2] ne '123'){die "Error: word: \$wd[2] ne '123'."}
X
+### Check array expabdable operation ###
+
+def reduce($ar,@$op)={expand $ar;while(nstack>=2){$op}}
+$real = ({1;2;3;4;5;shrink})
+$imag = ({0.1;0.2;0.3;0.4;0.5;shrink})
+$cmpx = $real + j $imag
+if(narray $cmpx != 5){ die "narray \$cmpx != 5"; }
+for ($i=0;$i<5;++$i) { \
+ if(Re $cmpx[$i] != $real[$i]) { die "Re \$cmpx[$i] != \$real[$i] }; \
+ if(Im $cmpx[$i] != $imag[$i]) { die "Im \$cmpx[$i] != \$imag[$i] }; \
+ $reim[$i] = $real[$i] + j $imag[$i]; \
+}
+if (reduce(Re $cmpx,@+) != reduce($real,@+)) { \
+ die "reduce(Re \$cmpx,@+) != reduce(\$real,@+)"; \
+}
+if (reduce(Im $cmpx,@+) != reduce($imag,@+)) { \
+ die "reduce(Im \$cmpx,@+) != reduce(\$imag,@+)"; \
+}
+if (reduce($cmpx==$reim,@&) != 1) { die "reduce($cmpx==$reim,@&) != 1"; }
+if (reduce($cmpx==$reim,@+) != 5) { die "reduce($cmpx==$reim,@+) != 5"; }
+
X
X #####################
X ### Trigonometric ###
SHAR_EOF
(set 20 04 12 01 22 56 13 'Cafe.bin.diff'; eval "$shar_touch") &&
chmod 0644 'Cafe.bin.diff' ||
$echo 'restore of' 'Cafe.bin.diff' 'failed'
if ( md5sum --help 2>&1 | grep 'sage: md5sum \[' ) >/dev/null 2>&1 \
&& ( md5sum --version 2>&1 | grep -v 'textutils 1.12' ) >/dev/null; then
md5sum -c << SHAR_EOF >/dev/null 2>&1 \
|| $echo 'Cafe.bin.diff:' 'MD5 check failed'
505a4fae07aa44dedfe169f2a1561884 Cafe.bin.diff
SHAR_EOF
else
v shar_count="`LC_ALL= LC_CTYPE= LANG= wc -c < 'Cafe.bin.diff'`"
test 48934 -eq "$shar_count" ||
$echo 'Cafe.bin.diff:' 'original size' '48934,' 'current size' "$shar_count!"
fi
fi
rm -fr _sh06517
exit 0
Fnews-brouse 1.9(20180406) -- by Mizuno, MWE <mwe@ccsf.jp>
GnuPG Key ID = ECC8A735
GnuPG Key fingerprint = 9BE6 B9E9 55A5 A499 CD51 946E 9BDC 7870 ECC8 A735