v23i089: ABC interactive programming environment, Part10/25
Rich Salz
rsalz at bbn.com
Wed Dec 19 06:38:04 AEST 1990
Submitted-by: Steven Pemberton <steven at cwi.nl>
Posting-number: Volume 23, Issue 89
Archive-name: abc/part10
#! /bin/sh
# This is a shell archive. Remove anything before this line, then feed it
# into a shell via "sh file" or similar. To overwrite existing files,
# type "sh file -c".
# The tool that generated this appeared in the comp.sources.unix newsgroup;
# send mail to comp-sources-unix at uunet.uu.net if you want that tool.
# Contents: abc/abc.msg abc/bed/e1edoc.c abc/bint1/i1fun.c
# abc/ch_config
# Wrapped by rsalz at litchi.bbn.com on Mon Dec 17 13:28:01 1990
PATH=/bin:/usr/bin:/usr/ucb ; export PATH
echo If this archive is complete, you will see the following message:
echo ' "shar: End of archive 10 (of 25)."'
if test -f 'abc/abc.msg' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'abc/abc.msg'\"
else
echo shar: Extracting \"'abc/abc.msg'\" \(18006 characters\)
sed "s/^X//" >'abc/abc.msg' <<'END_OF_FILE'
X100 removing non-existent list entry
X101 cannot remove from large range
X102 cannot insert in large range
X103 in keys t, t is not a table
X104 in t[k], t is not a table
X105 in t[k], k is not a key of t
X106* comp_text (106)
X200 in t|n, t is not a text
X201 in t|n, n is not a number
X202 in t|n, n is not an integer
X203 in t|n, n is < 0
X204 in t at n, t is not a text
X205 in t at n, n is not a number
X206 in t at n, n is not an integer
X207 in t at n, n is > #t + 1
X208 in t^u, t or u is not a text
X209 in t^u, the result is too long
X210 in t^^n, t is not a text
X211 in t^^n, n is not a number
X212 in t^^n, n is not an integer
X213 in t^^n, n is negative
X214 in t^^n, the result is too long
X215* charval on non-char (215)
X216* strval on big text (216)
X217* curtail on very big text (217)
X218* behead on very big text (218)
X219* concat on very big text (219)
X300 in #t, t is not a text list or table
X301 in e#t, t is not a text list or table
X302 in e#t, t is a text, but e is not a character
X303 in min t, t is not a text list or table
X304 in min t, t is empty
X305 in max t, t is not a text list or table
X306 in max t, t is empty
X307 in e min t, t is not a text list or table
X308 in e min t, t is empty
X309 in e min t, t is a text, but e is not a character
X310 in e min t, no element of t exceeds e
X311 in e max t, t is not a text list or table
X312 in e max t, t is empty
X313 in e max t, t is a text, but e is not a character
X314 in e max t, no element of t is less than e
X315 in t item n, t is not a text list or table
X316 in t item n, t is empty
X317 in t item n, n is not a number
X318 in t item n, n is not an integer
X319 in t item n, n is < 1
X320 in t item n, n exceeds #t
X321 in n th'of t, t is not a text list or table
X322 in n th'of t, t is empty
X323 in n th'of t, n is not a number
X324 in n th'of t, n is not an integer
X325 in n th'of t, n is < 1
X326 in n th'of t, n exceeds #t
X327* Bigsize in Bottom or Crange (327)
X400* unknown flag in ccopybtreenode (400)
X401* releasing unreferenced btreenode (401)
X402* wrong flag in relbtree() (402)
X500 incompatible types %s and %s
X501* comparison of unknown types (501)
X502* hash called with unknown type (502)
X503* unknown type in convert (503)
X600 in x mod y, y is zero
X601 in n round x, n is not an integer
X602 in */n, n is an approximate number
X603 in /*n, n is an approximate number
X604 in n root x, n is zero
X605 in root x, x is negative
X606 result of math function too large
X607 argument to math function too large
X608 math library error
X609 in log x, x <= 0
X610 in b log x, b <= 0
X611 in b log x, x <= 0
X700 approximate number too large
X701* app_floor: result not integral (701)
X800* numconst: can't happen (800)
X801 excessive exponent in e-notation
X900* dig_gcd of number(s) <= 0 (900)
X901* gcd_small of numbers > smallint (901)
X902* gcd of number(s) <= 0 (902)
X903 exceptionally large rational number
X1000* dig_gadd: nto < nfrom (1000)
X1001* int_tento(-n) (1001)
X1100* zero division (int_ldiv) (1100)
X1101* int_ldiv internal failure (1101)
X1200* mk_rat(x, y) with y=0 (1200)
X1300 number not an integer
X1301 exceedingly large integer
X1302* intval on non-number (1302)
X1303* num_comp (1303)
X1304 value not a number
X1305 approximate number too large to be handled
X1306 exceptionally large number
X1400 in p..q, p is neither a text nor a number
X1401 in p..q, p is a number but not an integer
X1402 in p..q, p is a number, but q is not
X1403 in p..q, q is a number but not an integer
X1404 in p..q, p is a text but not a character
X1405 in p..q, p is a text, but q is not
X1406 in p..q, q is a text, but not a character
X1500* big grabber (1500)
X1501* big regrabber (1501)
X1502* getsyze called with unknown type (1502)
X1503* releasing unreferenced value (1503)
X1600 in choice t, t is not a text list or table
X1601 in choice t, t is empty
X1700 Type '?' for help.\n
X1800 in i/j, j is zero
X1801 in 0**y or y root 0, y is negative
X1802 in x**(p/q) or (q/p) root x, x is negative and q is even
X1803 in x**y or y root x, x is negative and y is not exact
X1804 ambiguous expression; please use ( and ) to resolve
X1805 no expression where expected
X1806 no test where expected
X1807 something unexpected in expression
X1808 something unexpected in test
X1809 misformed address
X1810 %s hasn't been initialised or (properly) defined
X1811 %s hasn't been (properly) defined
X1812 %s has not yet received a value
X1813 function returns no value
X1814 predicate reports no outcome
X1815 a refinement may not be used as an address
X1816 bad node in while
X1817 bad node in testsuite
X1818 indentation not used consistently
X1819 indentation must be at least 2
X1820 selection on non-table
X1900* a_fpr_formals (1900)
X1901* analyze bad tree (1901)
X2000 no command suite where expected
X2001 no command where expected
X2002 something unexpected in this line
X2003 no parameter where expected
X2005 IN after colon
X2006 no alternative suite for SELECT
X2007 after ELSE no more alternatives allowed
X2100 nothing instead of expected expression
X2101 point without digits
X2102 e not followed by exponent
X2103 cannot find matching %s
X2200* fix bad tree (2200)
X2201* fix unparsed with bad flag (2201)
X2202 command cannot be reached
X2203 refinement returns no value or reports no outcome
X2204 wrong keyword %s
X2205 missing actual parameter after %s
X2206 can't find expected %s
X2207 unexpected actual parameter after %s
X2208 unexpected keyword %s
X2209 compound parameter has wrong length
X2210 refinement with parameters
X2211 you haven't told me HOW TO %s
X2212* f_fpr_formals (2212)
X2213 %s cannot be used in an expression
X2214 %s is neither a refined test nor a zeroadic predicate
X2300 wrong argument of type_check()
X2301 next line must be impossible as a refinement name, e.g. with a space:
X2302 returned value
X2303 RETURN not in function or expression refinement
X2304 Empty polytype stack
X2400 cannot find expected %s
X2401 no name where expected
X2402 no keyword where expected
X2403 something unexpected following %s
X2404 according to the syntax I expected %s
X2500 nothing where address expected
X2501 no address where expected
X2502 something unexpected in address
X2600 I found type
X2601 EG
X2602 where I expected
X2603 I thought
X2604 was of type
X2605 list or table of
X2606 list or table
X2607 "", or list or table of ""
X2608 text or list or table
X2609 incompatible type for
X2610 incompatible types for
X2611 and
X2612 %s
X2700 HAS follows colon
X2701 nothing instead of expected test
X2800 how-to starts with indentation
X2801 no how-to name where expected
X2802 no how-to keyword where expected
X2803 %s is a reserved keyword
X2804 %s is already a formal parameter or operand
X2805 %s is already a shared name
X2806 %s is already a refinement name
X2807 cannot find function name
X2808 user defined functions must be names
X2809 something unexpected in formula template
X2810 nothing instead of expected template operand
X2811 no template operand where expected
X2812 nothing instead of expected name
X2813 no name where expected
X2814 something unexpected in name
X2900 change of workspace not allowed
X2901 no previous workspace
X2902 I find no workspace name here
X2903 I can't goto/create workspace %s
X2905 *** I cannot find parent directory\n
X2906 *** I cannot find workspace\n
X2907 *** I cannot find your home directory\n
X2908 *** I shall use the current directory as your single workspace\n
X2909 *** %s isn't an ABC name\n
X2910 *** I shall try the default workspace\n
X3000* replacing in non-environment (3000)
X3001* deleting from non-environment (3001)
X3002* selection on non-environment (3002)
X3100 in your command\n
X3101 in your expression to be read\n
X3102 in your edited value\n
X3103 in your location %s\n
X3104 in your permanent environment\n
X3105 in your workspace index\n
X3106 in your how-to %s\n
X3107 in line %d of your how-to %s\n
X3108 *** (detected after reading 1 line of your input file standard input)\n
X3109 *** (detected after reading %d lines of your input file standard input)\n
X3110 *** (detected after reading 1 line of your input file %s)\n
X3111 *** (detected after reading %d lines of your input file %s)\n
X3112 *** The problem is:
X3113 *** Sorry, ABC system malfunction\n
X3114 *** Sorry, memory exhausted
X3115 *** There's something I don't understand
X3116 *** There's something I can't resolve
X3117 *** Can't cope with problem
X3118 *** Cannot reconcile the types
X3119 *** Your check failed
X3120 *** interrupted\n
X3200 in x %s y, x is not a number
X3201 in x %s y, y is not a number
X3202 in x %s y, y is not a compound of two numbers
X3203 in c %s x, c is zero
X3204 in %s x, x is not a number
X3205 in %s y, y is not a compound of two numbers
X3206 in %s t, t is not a text
X3207* pre-defined fpr wrong (3207)
X3208 in the test exact x, x is not a number
X3209 in the test e in t, t is not a text list or table
X3210 in the test e in t, t is a text, but e is not a character
X3211 in the test e not.in t, t is not a text list or table
X3212 in the test e not.in t, t is a text, but e isn't a character
X3213* predicate not covered by proposition (3213)
X3300 terminating commands only allowed in how-to's and refinements
X3301 share-command only allowed in a how-to
X3302 I don't recognise this as a command
X3303 outer indentation not zero
X3304 special commands only interactively
X3305* special (3305)
X3400 in ... i IN e, e is not a text, list or table
X3500 unexpected program halt
X3501* run: bad thread (3501)
X3502 none of the alternative tests of SELECT succeeds
X3503 test refinement reports no outcome
X3504 refinement returns no value
X3505 run-time error %s
X3506 run: cannot execute how-to definition
X3507* bad FPR_FORMAL (3507)
X3508 QUIT may only occur in a command or command-refinement
X3509 RETURN may only occur in a function or expression-refinement
X3510 REPORT may only occur in a predicate or test-refinement
X3511 SUCCEED may only occur in a predicate or test-refinement
X3512 FAIL may only occur in a predicate or test-refinement
X3513* run: bad node type (3513)
X3600 location not initialised
X3601 %s hasn't been initialised
X3602 key not in table
X3603 inserting in non-list
X3604 removing from non-list
X3605 removing from empty list
X3606 selection on empty table
X3607* call of location with improper type (3607)
X3608* uniquifying text-selection location (3608)
X3609* uniquifying comploc (3609)
X3610* uniquifying non-location (3610)
X3611 text-selection (@ or |) on non-text
X3612 in the location t at p or t|p, t does not contain a text
X3613 in the location t at p or t|p, p is out of bounds
X3614 selection on location of improper type
X3615 text-selection (@ or |) out of bounds
X3616 putting non-text in text-selection (@ or |)
X3617 putting non-compound in compound location
X3618 putting compound in compound location of different length
X3619 putting in non-location
X3620 putting different values in same location
X3621 deleting non-location
X3622 deleting text-selection (@ or |) location
X3623 deleting non-existent location
X3624 binding non-location
X3625 unbinding non-location
X3700 write error (disk full?)
X3800 value too big to output
X3801* writing value of unknown type (3801)
X3802 *** Please answer with '%c' or '%c'\n
X3803 *** Just '%c' or '%c', please\n
X3804 *** This is your last chance. Take it. I really don't know what you want.\n So answer the question\n
X3805 *** Well, I shall assume that your refusal to answer the question means '%c'!\n
X3806 End of input encountered during READ command
X3807 End of input encountered during READ t RAW
X3808 type of expression does not agree with that of EG sample
X3809 *** Please try again\n
X3900 *** abc: killed by signal\n
X3901 *** Oops, I feel suddenly (BURP!) indisposed. I'll call it a day. Sorry.\n
X3902 *** Oops, an act of God has occurred compelling me to discontinue service.\n
X3903 unexpected arithmetic overflow
X4000 cannot create file name for %s
X4001 filename and how-to name incompatible for %s
X4002 cannot create file %s; need write permission in directory
X4003 unable to find file
X4004* wrong nodetype of how-to (4004)
X4005 there is already a how-to with this name
X4006 there is already a permanent location with this name
X4007 *** the how-to name is already in use;\n*** should the old how-to be discarded?\n*** (if not you have to change the how-to name)\n
X4008 *** the how-to name is already in use for a permanent location;\n*** should that location be deleted?\n*** (if not you have to change the how-to name)\n
X4009 I find nothing editible here
X4010 no current how-to
X4011 *** do you want to visit the version with %c or %c operands?\n
X4012 *** you have no write permission in this workspace:\n*** you may not change the how-to\n*** do you still want to display the how-to?\n
X4013 *** cannot create file name;\n*** you have to change the how-to name\n
X4014 %s isn't a how-to in this workspace
X4015* ens_filed() (4015)
X4016 no current location
X4017 *** you have no write permission in this workspace:\n*** you may not change the location\n*** do you still want to display the location?\n
X4018 %s isn't a location in this workspace
X4019 value is not a table
X4020 in t[k], k is not a text
X4021 Press [SPACE] for more, [RETURN] to exit list
X4100* stack underflow (4100)
X4101* bad call type (4101)
X4102* stack clobbered (4102)
X4103 You haven't told me HOW TO REPORT %s
X4104 You haven't told me HOW TO RETURN %s
X4105* invoked how-to has other adicity than invoker (4105)
X4106* udfpr with predefined how-to (4106)
X4107* formula called with non-function (4107)
X4108* proposition called with non-predicate (4108)
X4109* extract (4109)
X4110 putting non-compound in compound parameter
X4111 parameter has wrong length
X4112* not a compound in sub_epibreer (4112)
X4113* bad nodetype in sub_epibreer (4113)
X4114* too many tags in sub_putback (4114)
X4115* not a compound in sub_putback (4115)
X4116* bad node type in sub_putback (4116)
X4117* not a compound in collect_value (4117)
X4118* bad node type in collect_value (4118)
X4119 on return, part of compound holds no value
X4120 value of expression parameter changed
X4121* bad def in x_user_command (4121)
X4122 You haven't told me HOW TO %s
X4200* loctype asked of non-location (4200)
X4201* valtype called with unknown type (4201)
X4400 in ... i IN e, i contains a non-local name
X4500* in cmdline() (4500)
X4600 *** %s isn't the name of a location\n
X4601 *** %s hasn't been initialised\n
X4602 *** %s isn't a table\n
X4603 *** Errors while recovering workspace:\n
X4604 *** %s: cannot derive a location name\n
X4605 *** %s: cannot read this file\n
X4606 *** %s: cannot derive a how-to name\n
X4607 *** %s: cannot rename this file\n
X4608 *** %s: the ABC name for this file is already in use\n
X4609 *** %s: cannot create this file\n
X4610 *** Errors while recovering the workspace index\n
X4611 *** %s: cannot derive an ABC name for this workspace\n
X4612 *** %s: the ABC name for this workspace is already in use\n
X4700 *** Interrupted\n
X6000 Empty copy buffer
X6001 Trouble with your how-to, see last line. Hit [interrupt] if you don't want this
X6002 Spaces and tabs mixed for indentation; check your program layout
X6003 There are still holes left. Please fill or delete these first.
X6004 I cannot [goto] that position
X6005 Sorry, I could not [goto] that position
X6006 You can't use [goto] in recording mode
X6007 Cannot insert '%c'
X6008 No keystrokes recorded
X6009 Keystrokes recorded, use [play] to play back
X6010 This redo brought you to an older version. Use [undo] to cancel
X6200 Sorry, I can't edit file \"%s\"
X6201 excessively nested indentation
X6202 indentation messed up
X6203 unexpected indentation increase
X6204* readsym: ungetc failed (6204)
X6300 Cannot save how-to on file \"%s\"
X6400 Recording
X6401 Copy buffer
X6500 Errors in key definitions file:\n
X6501 Definition for command %s starts with '%c'.
X6502 Definition for command %s would produce an interrupt or suspend.
X6503 Definition for command %s would produce an interrupt.
X6504 Too many key definitions
X6505 no '[' before name
X6506 No name after '['
X6507 no ']' after name
X6508 opening string quote not found
X6509 closing string quote not found in definition
X6510 definition string too long
X6511 opening string quote not found in representation
X6512 closing string quote not found in representation
X6513 unprintable character in representation
X6514 representation string too long
X6515 Name %s not followed by '='
X6516 Unknown command name: %s
X6517 Cannot rebind %s in keysfile
X6518 No '=' after definition for name %s
X6519* too many predefined keys (6519)
X6600 *** Bad $TERM or termcap, or dumb terminal\n
X6601 *** Bad SCREEN environment\n
X6602 *** Cannot reach keyboard or screen\n
X6700 Press [SPACE] for more, [RETURN] to exit help
X6701 Press [SPACE] or [RETURN] to exit help
X6702 *** Cannot find or read help file [%s]
X6800 *** Bad tgetent() return value.\n
X6801 *** Can't read termcap.\n
X6802 *** No description for your terminal.\n
X6900 \nUsage: abc [-W ws.group] [-w ws.name]\n
X6901 [ -e | -i tab | -o tab | -l | -r | -R | file ...]\n
X6902 \nWorkspace Options:\n
X6903 -W dir use group of workspaces in 'dir' (default $HOME/abc)\n
X6904 -w name start in workspace 'name' (default: last workspace)\n
X6905 -w path use 'path' as current workspace (no -W option allowed)\n
X6906 \nOther Options:\n
X6907 -e Use ${EDITOR} as editor to edit definitions\n
X6908 file ... Read commands from file(s)\n
X6909 \nSpecial tasks:\n
X6910 -i tab Fill table 'tab' with text lines from standard input\n
X6911 -o tab Write text lines from table 'tab' to standard output\n
X6912 -l List the how-to's in a workspace on standard output\n
X6913 -r Recover a workspace when its index is lost\n
X6914 -R Recover the index of a group of workspaces\n
X6915 \nUse 'abckeys' to change key bindings\n
X6916 *** incompatible workspace options\n
X6917 *** you have not set your environment variable EDITOR\n
X7000 *** can't finish writing suggestion file [%s]
X7100* s_up failed (7100)
X7101* s_downi failed (7101)
X7102* s_down failed (7102)
X7103* s_downrite failed (7103)
X8000 argument to graphics command not a vector
X8001 no graphics hardware available
END_OF_FILE
if test 18006 -ne `wc -c <'abc/abc.msg'`; then
echo shar: \"'abc/abc.msg'\" unpacked with wrong size!
fi
# end of 'abc/abc.msg'
fi
if test -f 'abc/bed/e1edoc.c' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'abc/bed/e1edoc.c'\"
else
echo shar: Extracting \"'abc/bed/e1edoc.c'\" \(15951 characters\)
sed "s/^X//" >'abc/bed/e1edoc.c' <<'END_OF_FILE'
X/* Copyright (c) Stichting Mathematisch Centrum, Amsterdam, 1986. */
X
X#include "b.h"
X#include "bedi.h"
X#include "etex.h"
X#include "feat.h"
X#include "bobj.h"
X#include "defs.h"
X#include "node.h"
X#include "erro.h"
X#include "gram.h"
X#include "keys.h"
X#include "queu.h"
X#include "supr.h"
X#include "tabl.h"
X
Xextern bool io_exit;
Xextern bool slowterminal;
X
X#define Mod(k) (((k)+MAXHIST) % MAXHIST)
X#define Succ(k) (((k)+1) % MAXHIST)
X#define Pred(k) (((k)+MAXHIST-1) % MAXHIST)
X
X#define CANT_SAVE MESS(6300, "Cannot save how-to on file \"%s\"")
X
Xextern environ *tobesaved;
Xextern string savewhere;
X
XHidden int highwatmark = Maxintlet;
X
XVisible bool lefttorite;
X /* Saves some time in nosuggtoqueue() for read from file */
X
X/*
X * Edit a unit or target, using the environment offered as a parameter.
X */
X
XVisible bool
Xdofile(ep, filename, linenumber, kind, creating)
X environ *ep;
X string filename;
X int linenumber;
X literal kind;
X bool creating;
X{
X bool read_bad= No;
X bool readfile();
X
X#ifdef SAVEPOS
X if (linenumber <= 0)
X linenumber = getpos(filename);
X#endif /* SAVEPOS */
X setroot(kind == '=' ? Target_edit : Unit_edit);
X savewhere = filename;
X tobesaved = (environ*)NULL;
X
X lefttorite = Yes;
X if (!readfile(ep, filename, linenumber, creating)) {
X ederr(READ_BAD);
X read_bad = Yes;
X }
X#ifdef USERSUGG
X readsugg(ep->focus);
X#endif /* USERSUGG */
X lefttorite = No;
X
X ep->generation = 0;
X if (!editdocument(ep, read_bad))
X return No;
X if (ep->generation > 0) {
X if (!save(ep->focus, filename))
X ederrS(CANT_SAVE, filename);
X#ifdef USERSUGG
X writesugg(ep->focus);
X#endif /* USERSUGG */
X }
X#ifdef SAVEPOS
X savpos(filename, ep);
X#endif /* SAVEPOS */
X savewhere = (char*)NULL;
X tobesaved = (environ*)NULL;
X return Yes;
X}
X
X
X/*
X * Call the editor for a given document.
X */
X
XVisible bool
Xeditdocument(ep, bad_file)
X environ *ep;
X bool bad_file;
X{
X int k;
X int first = 0;
X int last = 0;
X int current = 0;
X int onscreen = -1;
X bool reverse = No;
X environ newenv;
X int cmd;
X bool errors = No;
X int undoage = 0;
X bool done = No;
X int height;
X environ history[MAXHIST];
X
X Ecopy(*ep, history[0]);
X
X for (;;) { /* Command interpretation loop */
X if (reverse && onscreen >= 0)
X height = history[onscreen].highest;
X else
X height = history[current].highest;
X if (height < highwatmark) highwatmark = height;
X if (done)
X break;
X if (!interrupted && trmavail() <= 0) {
X if (onscreen != current)
X virtupdate(onscreen < 0 ? (environ*)NULL : &history[onscreen],
X &history[current],
X reverse && onscreen >= 0 ?
X history[onscreen].highest : history[current].highest);
X onscreen = current;
X highwatmark = Maxintlet;
X actupdate(history[current].copyflag ?
X history[current].copybuffer : Vnil,
X#ifdef RECORDING
X history[current].newmacro != Vnil,
X#else /* !RECORDING */
X No,
X#endif /* !RECORDING */
X No);
X }
X if (interrupted) break;
X#ifdef MENUS
X adjusteditmenu(
X (bool) (ishole(&history[current])),
X (bool) (history[current].copybuffer != Vnil),
X (bool) (history[current].copyflag),
X (bool) (current != first),
X (bool) (current != last)
X );
X#endif
X cmd = inchar();
X
X errors = No;
X switch (cmd) {
X
X case UNDO:
X if (current == first)
X errors = Yes;
X else {
X if (onscreen == current)
X reverse = Yes;
X current = Pred(current);
X undoage = Mod(last-current);
X }
X break;
X
X case REDO:
X if (current == last)
X errors = Yes;
X else {
X if (current == onscreen)
X reverse = No;
X if (history[Succ(current)].generation <
X history[current].generation)
X ederr(REDO_OLD); /***** Should refuse altogether??? *****/
X current = Succ(current);
X undoage = Mod(last-current);
X }
X break;
X
X#ifdef HELPFUL
X case HELP:
X if (help())
X onscreen = -1;
X break;
X#endif /* HELPFUL */
X
X case SUSPEND:
X /* after suspend handled by susphandler() */
X onscreen= -1;
X trmundefined();
X if (doctype == D_immcmd)
X cmdprompt(CMDPROMPT);
X break;
X
X case REDRAW:
X onscreen = -1;
X trmundefined();
X break;
X
X case EOF:
X done = Yes;
X break;
X
X case CANCEL:
X if (bad_file) {
X#ifdef MENUS
X unhilite();
X#endif
X return No;
X }
X else if (doctype == D_input ||
X (doctype == D_immcmd && current == first))
X interrupted= Yes;
X else
X errors= Yes;
X break;
X
X default:
X Ecopy(history[current], newenv);
X newenv.highest = Maxintlet;
X newenv.changed = No;
X if (cmd != EXIT)
X errors = !execute(&newenv, cmd) || !checkep(&newenv);
X else {
X done = Yes;
X io_exit= Yes;
X }
X#ifdef EDITRACE
X dumpev(&newenv, "AFTER EXECUTE");
X#endif
X if (errors) {
X switch (cmd) {
X case NEWLINE:
X if (newenv.mode == ATEND && !parent(newenv.focus)) {
X errors = !checkep(&newenv);
X if (!errors) {
X#ifdef USERSUGG
X check_last_unit(&newenv, current);
X#endif
X done = Yes;
X }
X }
X break;
X#ifdef HELPFUL
X case '?':
X cmd = HELP;
X /* FALL THROUGH: */
X case HELP:
X if (help())
X onscreen = -1;
X#endif /* HELPFUL */
X }
X }
X if (errors)
X Erelease(newenv);
X else {
X#ifndef SMALLSYS
X if (done)
X#ifdef MENUS
X if (!terminated)
X#endif
X done = canexit(&newenv);
X if (!done)
X io_exit= No;
X#endif /* SMALLSYS */
X if (!done && ev_eq(&newenv, &history[current])) {
X errors= Yes;
X Erelease(newenv);
X break; /* don't remember no.ops */
X }
X if (newenv.changed)
X ++newenv.generation;
X last = Succ(last);
X current = Succ(current);
X if (last == first) {
X /* Array full (always after a while). Discard "oldest". */
X if (current == last
X || undoage < Mod(current-first)) {
X Erelease(history[first]);
X first = Succ(first);
X if (undoage < MAXHIST)
X ++undoage;
X }
X else {
X last = Pred(last);
X Erelease(history[last]);
X }
X }
X if (current != last
X && newenv.highest < history[current].highest)
X history[current].highest = newenv.highest;
X /* Move entries beyond current one up. */
X for (k = last; k != current; k = Pred(k)) {
X if (Pred(k) == onscreen)
X onscreen = k;
X Emove(history[Pred(k)], history[k]);
X }
X Ecopy(newenv, history[current]);
X Erelease(history[current]);
X }
X break; /* default */
X
X } /* switch */
X
X if (errors
X#ifdef HELPFUL
X && cmd != HELP
X#endif
X ) {
X if (!slowterminal && isascii(cmd)
X && (isprint(cmd) || cmd == ' '))
X ederrC(INS_BAD, cmd);
X else
X ederr(0);
X }
X if (savewhere)
X tobesaved = &history[current];
X } /* for (;;) */
X
X if (onscreen != current)
X virtupdate(onscreen < 0 ? (environ*)NULL : &history[onscreen],
X &history[current], highwatmark);
X actupdate(Vnil, No, Yes);
X Erelease(*ep);
X Ecopy(history[current], *ep);
X if (savewhere)
X tobesaved = ep;
X for (current = first; current != last; current = Succ(current))
X Erelease(history[current]);
X Erelease(history[last]);
X#ifdef MENUS
X unhilite();
X#endif
X return Yes;
X}
X
X/*
X * Execute a command, return success or failure.
X */
X
Xextern bool justgoon;
X
XHidden bool
Xexecute(ep, cmd)
X register environ *ep;
X register int cmd;
X{
X register bool spflag = ep->spflag;
X register int i;
X environ ev;
X char buf[2];
X char ch;
X int len;
X#ifdef USERSUGG
X bool sugg;
X int sym= symbol(tree(ep->focus));
X
X sugg = sym == Suggestion;
X#define ACKSUGG(ep) if (sugg) acksugg(ep)
X#define KILLSUGG(ep) if (sugg) killsugg(ep, (string*)NULL); \
X else if (sym==Sugghowname) ackhowsugg(ep)
X#else /* !USERSUGG */
X#define ACKSUGG(ep) /* NULL */
X#define KILLSUGG(ep) /* NULL */
X#endif /* !USERSUGG */
X
X if (justgoon)
X justgoon = isascii(cmd) && islower(cmd);
X
X#ifdef RECORDING
X if (ep->newmacro && cmd != RECORD && cmd != PLAYBACK) {
X value t;
X buf[0] = cmd; buf[1] = 0;
X e_concto(&ep->newmacro, t= mk_etext(buf));
X release(t);
X }
X#endif /* RECORDING */
X ep->spflag = No;
X
X switch (cmd) {
X
X#ifdef RECORDING
X case RECORD:
X ep->spflag = spflag;
X if (ep->newmacro) { /* End definition */
X release(ep->oldmacro);
X if (ep->newmacro && e_length(ep->newmacro) > 0) {
X ep->oldmacro = ep->newmacro;
X edmessage(getmess(REC_OK));
X }
X else {
X release(ep->newmacro);
X ep->oldmacro = Vnil;
X }
X ep->newmacro = Vnil;
X }
X else /* Start definition */
X ep->newmacro = mk_etext("");
X return Yes;
X
X case PLAYBACK:
X if (!ep->oldmacro || e_length(ep->oldmacro) <= 0) {
X ederr(PLB_NOK);
X return No;
X }
X ep->spflag = spflag;
X len= e_length(ep->oldmacro);
X for (i = 0; i < len; ++i) {
X ch= e_ncharval(i+1, ep->oldmacro);
X Ecopy(*ep, ev);
X if (execute(ep, ch&0377) && checkep(ep))
X Erelease(ev);
X else {
X Erelease(*ep);
X Emove(ev, *ep);
X if (!i)
X return No;
X ederr(0); /* Just a bell */
X /* The error must be signalled here, because the overall
X command (PLAYBACK) succeeds, so the main loop
X doesn't ring the bell; but we want to inform the
X that not everything was done either. */
X return Yes;
X }
X }
X return Yes;
X#endif /* RECORDING */
X
X#ifdef GOTOCURSOR
X case GOTO:
X ACKSUGG(ep);
X#ifdef RECORDING
X if (ep->newmacro) {
X ederr(GOTO_REC);
X return No;
X }
X#endif /* RECORDING */
X return gotocursor(ep);
X#endif /* GOTOCURSOR */
X
X case NEXT:
X ACKSUGG(ep);
X return nextarrow(ep);
X
X case PREVIOUS:
X ACKSUGG(ep);
X return previous(ep);
X
X case LEFTARROW:
X ACKSUGG(ep);
X return leftarrow(ep);
X
X case RITEARROW:
X ACKSUGG(ep);
X return ritearrow(ep);
X
X case WIDEN:
X ACKSUGG(ep);
X return widen(ep, No);
X
X case EXTEND:
X ACKSUGG(ep);
X return extend(ep);
X
X case FIRST:
X ACKSUGG(ep);
X return narrow(ep);
X
X case LAST:
X ACKSUGG(ep);
X return rnarrow(ep);
X
X case UPARROW:
X ACKSUGG(ep);
X return uparrow(ep);
X
X case DOWNARROW:
X ACKSUGG(ep);
X return downarrow(ep);
X
X case UPLINE:
X ACKSUGG(ep);
X return upline(ep);
X
X case DOWNLINE:
X ACKSUGG(ep);
X return downline(ep);
X
X
X case PASTE:
X case COPY:
X ACKSUGG(ep);
X ep->spflag = spflag;
X return copyinout(ep);
X
X case CUT:
X case DELETE:
X ACKSUGG(ep);
X return deltext(ep);
X
X case ACCEPT:
X ACKSUGG(ep);
X return accept(ep);
X
X default:
X if (!isascii(cmd) || !isprint(cmd))
X return No;
X ep->spflag = spflag;
X return ins_char(ep, cmd, islower(cmd) ? toupper(cmd) : -1);
X
X case ' ':
X ep->spflag = spflag;
X return ins_char(ep, ' ', -1);
X
X case NEWLINE:
X KILLSUGG(ep);
X return ins_newline(ep);
X }
X}
X
X
X/*
X * Initialize an environment variable. Most things are set to 0 or NULL.
X */
X
XVisible Procedure
Xclrenv(ep)
X environ *ep;
X{
X ep->focus = newpath(NilPath, gram(Optional), 1);
X ep->mode = WHOLE;
X ep->copyflag = ep->spflag = ep->changed = No;
X ep->s1 = ep->s2 = ep->s3 = 0;
X ep->highest = Maxintlet;
X ep->copybuffer = Vnil;
X#ifdef RECORDING
X ep->oldmacro = ep->newmacro = Vnil;
X#endif /* RECORDING */
X ep->generation = 0;
X ep->changed = No;
X}
X
X/*
X * Find out if the current position is higher in the tree
X * than `ever' before (as remembered in ep->highest).
X * The algorithm of pathlength() is repeated here to gain
X * some efficiency by stopping as soon as it is clear
X * no change can occur.
X * (Higher() is called VERY often, so this pays).
X */
X
XVisible Procedure
Xhigher(ep)
X register environ *ep;
X{
X register path p = ep->focus;
X register int pl = 0;
X register int max = ep->highest;
X
X while (p) {
X ++pl;
X if (pl >= max)
X return;
X p = parent(p);
X }
X ep->highest = pl;
X}
X
X#ifndef NDEBUG
X
X/*
X * Issue debug status message.
X */
X
XVisible Procedure
Xdbmess(ep)
X register environ *ep;
X{
X#ifndef SMALLSYS
X char stuff[80];
X register string str = stuff;
X
X switch (ep->mode) {
X case VHOLE:
X sprintf(stuff, "VHOLE:%d.%d", ep->s1, ep->s2);
X break;
X case FHOLE:
X sprintf(stuff, "FHOLE:%d.%d", ep->s1, ep->s2);
X break;
X case ATBEGIN:
X str = "ATBEGIN";
X break;
X case ATEND:
X str = "ATEND";
X break;
X case WHOLE:
X str = "WHOLE";
X break;
X case SUBRANGE:
X sprintf(stuff, "SUBRANGE:%d.%d-%d", ep->s1, ep->s2, ep->s3);
X break;
X case SUBSET:
X sprintf(stuff, "SUBSET:%d-%d", ep->s1, ep->s2);
X break;
X case SUBLIST:
X sprintf(stuff, "SUBLIST...%d", ep->s3);
X break;
X default:
X sprintf(stuff, "UNKNOWN:%d,%d,%d,%d",
X ep->mode, ep->s1, ep->s2, ep->s3);
X }
X sprintf(messbuf,
X#ifdef SAVEBUF
X "%s, %s, wi=%d, hi=%d, (y,x,l)=(%d,%d,%d) %s",
X symname(symbol(tree(ep->focus))),
X#else /* !SAVEBUF */
X "%d, %s, wi=%d, hi=%d, (y,x,l)=(%d,%d,%d) %s",
X symbol(tree(ep->focus)),
X#endif /* SAVEBUF */
X str, nodewidth(tree(ep->focus)), ep->highest,
X Ycoord(ep->focus), Xcoord(ep->focus), Level(ep->focus),
X ep->spflag ? "spflag on" : "");
X#endif /* !SMALLSYS */
X edmessage(messbuf);
X}
X
X#endif /* NDEBUG */
X
X#ifndef SMALLSYS
X
XHidden bool
Xcanexit(ep)
X environ *ep;
X{
X environ ev;
X
X shrink(ep);
X if (ishole(ep))
X VOID deltext(ep);
X Ecopy(*ep, ev);
X top(&ep->focus);
X higher(ep);
X ep->mode = WHOLE;
X if (findhole(&ep->focus)) {
X Erelease(ev);
X ederr(EXIT_HOLES); /* There are holes left */
X return No;
X }
X Erelease(*ep);
X Emove(ev, *ep);
X return Yes;
X}
X
X
XHidden bool
Xfindhole(pp)
X register path *pp;
X{
X register node n = tree(*pp);
X
X if (Is_etext(n))
X return No;
X if (symbol(n) == Hole)
X return Yes;
X if (!down(pp))
X return No;
X for (;;) {
X if (findhole(pp))
X return Yes;
X if (!rite(pp))
X break;
X
X }
X if (!up(pp)) Abort();
X return No;
X}
X
X#endif /* !SMALLSYS */
X
X/* ------------------------------------------------------------------ */
X
X#ifdef SAVEBUF
X
X/*
X * Write a node.
X */
X
X#ifdef DUMPING_QUEUES
XVisible Procedure
X#else
XHidden Procedure
X#endif
Xwritenode(n, fp)
X node n;
X FILE *fp;
X{
X int nch;
X int i;
X
X if (!n) {
X fputs("(0)", fp);
X return;
X }
X if (((value)n)->type == Etex) {
X writetext((value)n, fp);
X return;
X }
X nch = nchildren(n);
X fprintf(fp, "(%s", symname(symbol(n)));
X for (i = 1; i <= nch; ++i) {
X putc(',', fp);
X writenode(child(n, i), fp);
X }
X fputc(')', fp);
X}
X
X
XHidden Procedure
Xwritetext(v, fp)
X value v;
X FILE *fp;
X{
X intlet k, len;
X int c;
X
X Assert(v && Is_etext(v));
X len= e_length(v);
X putc('\'', fp);
X for (k= 0; k<len; ++k) {
X c= e_ncharval(k+1, v);
X if (c == ' ' || isprint(c)) {
X putc(c, fp);
X if (c == '\'' || c == '`')
X putc(c, fp);
X }
X else if (isascii(c))
X fprintf(fp, "`$%d`", c);
X }
X putc('\'', fp);
X}
X
X
XVisible bool
Xsavequeue(v, filename)
X value v;
X string filename;
X{
X register FILE *fp;
X auto queue q = (queue)v;
X register node n;
X register bool ok;
X register int lines = 0;
X
X fp = fopen(filename, "w");
X if (!fp)
X return No;
X q = qcopy(q);
X while (!emptyqueue(q)) {
X n = queuebehead(&q);
X writenode(n, fp);
X putc('\n', fp);
X ++lines;
X noderelease(n);
X }
X ok = fclose(fp) != EOF;
X if (!lines)
X /* Try to */ unlink(filename); /***** UNIX! *****/
X return ok;
X}
X#endif /* SAVEBUF */
X
X#ifdef SAVEBUF
X#ifdef EDITRACE
Xextern FILE *dumpfp;
X
XVisible Procedure dumpev(ep, m) register environ *ep; string m;
X{
X char stuff[80];
X register string str = stuff;
X path pa;
X node n;
X int ich;
X static int idump;
X
X if (dumpfp == NULL)
X return;
X
X idump++;
X fprintf(dumpfp, "+++ EV %d: %s +++\n", idump, m);
X
X switch (ep->mode) {
X case VHOLE:
X sprintf(str, "VHOLE:%d.%d", ep->s1, ep->s2);
X break;
X case FHOLE:
X sprintf(str, "FHOLE:%d.%d", ep->s1, ep->s2);
X break;
X case ATBEGIN:
X str = "ATBEGIN";
X break;
X case ATEND:
X str = "ATEND";
X break;
X case WHOLE:
X str = "WHOLE";
X break;
X case SUBRANGE:
X sprintf(str, "SUBRANGE:%d.%d-%d", ep->s1, ep->s2, ep->s3);
X break;
X case SUBSET:
X sprintf(str, "SUBSET:%d-%d", ep->s1, ep->s2);
X break;
X case SUBLIST:
X sprintf(str, "SUBLIST...%d", ep->s3);
X break;
X default:
X sprintf(str, "UNKNOWN:%d,%d,%d,%d",
X ep->mode, ep->s1, ep->s2, ep->s3);
X }
X n= tree(ep->focus);
X fprintf(dumpfp,
X "%s, %s, wi=%d, hi=%d, (y,x,l)=(%d,%d,%d) %s %s\n",
X (Is_etext(n) ? "<TEXT> " : symname(symbol(n))),
X str, nodewidth(n), ep->highest,
X Ycoord(ep->focus), Xcoord(ep->focus), Level(ep->focus),
X ep->spflag ? "spflag on" : "",
X ep->changed ? "changed" : "");
X writenode(n, dumpfp);
X pa= parent(ep->focus);
X ich= ichild(ep->focus);
X while (pa != NilPath) {
X fprintf(dumpfp, " IN PARENT AT %d:\n", ich);
X writenode(tree(pa), dumpfp);
X ich= ichild(pa);
X pa= parent(pa);
X }
X fprintf(dumpfp, "\n");
X fflush(dumpfp);
X}
X#endif /*DUMPEV*/
X#endif /*SAVEBUF*/
END_OF_FILE
if test 15951 -ne `wc -c <'abc/bed/e1edoc.c'`; then
echo shar: \"'abc/bed/e1edoc.c'\" unpacked with wrong size!
fi
# end of 'abc/bed/e1edoc.c'
fi
if test -f 'abc/bint1/i1fun.c' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'abc/bint1/i1fun.c'\"
else
echo shar: Extracting \"'abc/bint1/i1fun.c'\" \(16456 characters\)
sed "s/^X//" >'abc/bint1/i1fun.c' <<'END_OF_FILE'
X/* Copyright (c) Stichting Mathematisch Centrum, Amsterdam, 1986. */
X
X/* Functions defined on numeric values. */
X
X#include <errno.h> /* For EDOM and ERANGE */
X
X#include "b.h"
X#include "feat.h" /* for EXT_RANGE */
X#include "bobj.h"
X#include "i0err.h"
X#include "i1num.h"
X
X/*
X * The visible routines here implement predefined B arithmetic operators,
X * taking one or two numeric values as operands, and returning a numeric
X * value.
X * No type checking of operands is done: this must be done by the caller.
X */
X
Xtypedef value (*valfun)();
Xtypedef rational (*ratfun)();
Xtypedef real (*appfun)();
Xtypedef double (*mathfun)();
X
X/*
X * For the arithmetic functions (+, -, *, /) the same action is needed:
X * 1) if both operands are Integral, use function from int_* submodule;
X * 2) if both are Exact, use function from rat_* submodule (after possibly
X * converting one of them from Integral to Rational);
X * 3) otherwise, make both approximate and use function from app_*
X * submodule.
X * The functions performing the appropriate action for each of the submodules
X * are passed as parameters.
X * Division is a slight exception, since i/j can be a rational.
X * See `quot' below.
X */
X
XHidden value dyop(u, v, int_fun, rat_fun, app_fun)
X value u, v;
X valfun int_fun;
X ratfun rat_fun;
X appfun app_fun;
X{
X if (Integral(u) && Integral(v)) /* Use integral operation */
X return (*int_fun)(u, v);
X
X if (Exact(u) && Exact(v)) {
X rational u1, v1, a;
X
X /* Use rational operation */
X
X u1 = Integral(u) ? mk_rat((integer)u, int_1, 0, Yes) :
X (rational) Copy(u);
X v1 = Integral(v) ? mk_rat((integer)v, int_1, 0, Yes) :
X (rational) Copy(v);
X a = (*rat_fun)(u1, v1);
X Release(u1);
X Release(v1);
X
X if (Denominator(a) == int_1 && Roundsize(a) == 0) {
X integer b = (integer) Copy(Numerator(a));
X Release(a);
X return (value) b;
X }
X
X return (value) a;
X }
X
X /* Use approximate operation */
X
X {
X real u1, v1, a;
X u1 = Approximate(u) ? (real) Copy(u) : (real) approximate(u);
X v1 = Approximate(v) ? (real) Copy(v) : (real) approximate(v);
X a = (*app_fun)(u1, v1);
X Release(u1);
X Release(v1);
X
X return (value) a;
X }
X}
X
X
XVisible value sum(u, v) value u, v; {
X if (IsSmallInt(u) && IsSmallInt(v))
X return (value) mk_int(
X (double)SmallIntVal(u) + (double)SmallIntVal(v));
X return dyop(u, v, (value (*)())int_sum, rat_sum, app_sum);
X}
X
XVisible value diff(u, v) value u, v; {
X if (IsSmallInt(u) && IsSmallInt(v))
X return (value) mk_int(
X (double)SmallIntVal(u) - (double)SmallIntVal(v));
X return dyop(u, v, (value (*)())int_diff, rat_diff, app_diff);
X}
X
XVisible value prod(u, v) value u, v; {
X if (IsSmallInt(u) && IsSmallInt(v))
X return (value) mk_int(
X (double)SmallIntVal(u) * (double)SmallIntVal(v));
X return dyop(u, v, (value (*)())int_prod, rat_prod, app_prod);
X}
X
X
X/*
X * We cannot use int_quot (which performs integer division with truncation).
X * Here is the routine we need.
X */
X
XHidden value xxx_quot(u, v) integer u, v; {
X
X if (v == int_0) {
X interr(ZERO_DIVIDE);
X return (value) Copy(u);
X }
X
X return mk_exact(u, v, 0);
X}
X
XVisible value quot(u, v) value u, v; {
X return dyop(u, v, xxx_quot, rat_quot, app_quot);
X}
X
X
X/*
X * Unary minus and abs follow the same principle but with only one operand.
X */
X
XVisible value negated(u) value u; {
X if (IsSmallInt(u)) return mk_integer(-SmallIntVal(u));
X if (Integral(u))
X return (value) int_neg((integer)u);
X if (Rational(u))
X return (value) rat_neg((rational)u);
X return (value) app_neg((real)u);
X}
X
X
XVisible value absval(u) value u; {
X if (Integral(u)) {
X if (Msd((integer)u) < 0)
X return (value) int_neg((integer)u);
X } else if (Rational(u)) {
X if (Msd(Numerator((rational)u)) < 0)
X return (value) rat_neg((rational)u);
X } else if (Approximate(u) && Frac((real)u) < 0)
X return (value) app_neg((real)u);
X
X return Copy(u);
X}
X
X
X/*
X * The remaining operators follow less similar paths and some of
X * them contain quite subtle code.
X */
X
XVisible value mod(u, v) value u, v; {
X value q, f, d, p;
X
X if (v == (value)int_0 ||
X Rational(v) && Numerator((rational)v) == int_0 ||
X Approximate(v) && Frac((real)v) == 0) {
X interr(MESS(600, "in x mod y, y is zero"));
X return Copy(u);
X }
X
X if (Integral(u) && Integral(v))
X return (value) int_mod((integer)u, (integer)v);
X
X /* Compute `(u/v-floor(u/v))*v', which prevents loss of precision;
X don't use `u-v*floor(u/v)', as in the formal definition of `mod'. */
X
X q = quot(u, v);
X f = floorf(q);
X d = diff(q, f);
X release(q);
X release(f);
X p = prod(d, v);
X release(d);
X
X return p;
X}
X
X
X/*
X * u**v has the most special cases of all the predefined arithmetic functions.
X */
X
XVisible value power(u, v) value u, v; {
X real ru, rv, rw;
X if (Exact(u) && (Integral(v) ||
X /* Next check catches for integers disguised as rationals: */
X Rational(v) && Denominator((rational)v) == int_1)) {
X rational a;
X integer b = Integral(v) ? (integer)v : Numerator((rational)v);
X /* Now b is really an integer. */
X
X u = Integral(u) ? (value) mk_rat((integer)u, int_1, 0, Yes) :
X Copy(u);
X a = rat_power((rational)u, b);
X Release(u);
X if (Denominator(a) == int_1) { /* Make integral result */
X b = (integer) Copy(Numerator(a));
X Release(a);
X return (value)b;
X }
X return (value)a;
X }
X
X if (Exact(v)) {
X integer vn, vd;
X int s;
X ru = (real) approximate(u);
X if (v == (value) int_2) {
X /* speed up common formula u**2 */
X rw= app_prod(ru, ru);
X Release(ru);
X return (value) rw;
X }
X if (about2_to_integral(ru, v, &rv)) {
X /* to speed up reading the value of an approximate
X * from a file, the exponent part is stored as
X * ~2**expo;
X * we want to return the value (0.5, expo+1) to
X * prevent loss of precision, but the normal way
X * via app_power() isn't good enough;
X */
X Release(ru);
X return (value) rv;
X }
X s = (Frac(ru) > 0) - (Frac(ru) < 0);
X
X if (s < 0) rv = app_neg(ru), Release(ru), ru = rv;
X if (Integral(v)) {
X vn = (integer)v;
X vd = int_1;
X } else {
X vd = Denominator((rational)v);
X if (s < 0 && Even(Lsd(vd)))
X interr(NEG_EVEN);
X vn = Numerator((rational)v);
X }
X if (vn == int_0) {
X Release(ru);
X return one;
X }
X if (s == 0 && Msd(vn) < 0) {
X interr(NEG_POWER);
X return (value) ru;
X }
X if (s < 0 && Even(Lsd(vn)))
X s = 1;
X rv = (real) approximate(v);
X rw = app_power(ru, rv);
X Release(ru), Release(rv);
X if (s < 0) ru = app_neg(rw), Release(rw), rw = ru;
X return (value) rw;
X }
X
X /* Everything else: we now know u or v is approximate */
X
X ru = (real) approximate(u);
X if (Frac(ru) < 0) {
X interr(NEG_EXACT);
X return (value) ru;
X }
X rv = (real) approximate(v);
X if (Frac(ru) == 0 && Frac(rv) < 0) {
X interr(NEG_POWER);
X Release(rv);
X return (value) ru;
X }
X rw = app_power(ru, rv);
X Release(ru), Release(rv);
X return (value) rw;
X}
X
X
X/*
X * floor: for approximate numbers app_floor() is used;
X * for integers it is a no-op; other exact numbers effectively calculate
X * u - (u mod 1).
X */
X
XVisible value floorf(u) value u; {
X integer quo, rem, v;
X digit div;
X
X if (Integral(u)) return Copy(u);
X if (Approximate(u)) return (value) app_floor((real)u);
X
X /* It is a rational number */
X
X div = int_ldiv(Numerator((rational)u), Denominator((rational)u),
X &quo, &rem);
X if (div < 0 && rem != int_0) { /* Correction for negative noninteger */
X v = int_diff(quo, int_1);
X Release(quo);
X quo = v;
X }
X Release(rem);
X return (value) quo;
X}
X
X
X/*
X * ceiling x is defined as -floor(-x);
X * and that's how it's implemented, except for integers.
X */
X
XVisible value ceilf(u) value u; {
X value v;
X if (Integral(u)) return Copy(u);
X u = negated(u);
X v = floorf(u);
X release(u);
X u = negated(v);
X release(v);
X return u;
X}
X
X
X/*
X * round u is defined as floor(u+0.5), which is what is done here,
X * except for integers which are left unchanged;
X * for rationals the sum u+0.5 isn't normalized; there is no harm in
X * that because of the division in floorf()
X */
X
XVisible value round1(u) value u; {
X value v, w; bool neg = No;
X
X if (Integral(u)) return Copy(u);
X
X if (numcomp(u, zero) < 0) {
X neg = Yes;
X u = negated(u);
X }
X
X if (Approximate(u)) {
X value w = approximate((value) rat_half);
X v = (value) app_sum((real) u, (real) w);
X release(w);
X }
X else v = (value) ratsumhalf((rational) u);
X
X w = floorf(v);
X release(v);
X
X if (neg) {
X release(u);
X w = negated(v=w);
X release(v);
X }
X
X return w;
X}
X
X
X/*
X * u round v is defined as 10**-u * round(v*10**u).
X * A complication is that u round v is always printed with exactly u digits
X * after the decimal point, even if this involves trailing zeros,
X * or if v is an integer.
X * Consequently, the result is always kept as a rational, even if it can be
X * simplified to an integer, and the size field of the rational number
X * (which is made negative to distinguish it from integers, and < -1 to
X * distinguish it from approximate numbers) is used to store the number of
X * significant digits.
X * Thus a size of -2 means a normal rational number, and a size < -2
X * means a rounded number to be printed with (-2 - length) digits
X * after the decimal point. This last expression can be retrieved using
X * the macro Roundsize(v) which should only be applied to Rational
X * numbers.
X *
X * prod10n() is a routine with does a fast multiplication with a ten power
X * and does not simplify a rational result sometimes.
X */
X
XVisible value round2(n, v) value n, v; {
X value w;
X int i;
X
X if (!Integral(n)) {
X interr(MESS(601, "in n round x, n is not an integer"));
X i = 0;
X } else
X i = propintlet(intval(n));
X
X w = Approximate(v) ? exactly(v) : copy(v);
X
X v = prod10n(w, i, No);
X /* v will be rounded, so it isn't simplified if a rational */
X release(w);
X
X v = round1(w = v);
X release(w);
X
X v = prod10n(w = v, -i, Yes);
X release(w);
X
X if (i > 0) { /* Set number of digits to be printed */
X if (propintlet(-2 - i) < -2) {
X if (Rational(v))
X Length(v) = -2 - i;
X else if (Integral(v)) {
X w = v;
X v = mk_exact((integer) w, int_1, i);
X release(w);
X }
X }
X }
X
X return v;
X}
X
X
X/*
X * sign u inspects the sign of either u, u's numerator or u's fractional part.
X */
X
XVisible value signum(u) value u; {
X int s;
X
X if (Exact(u)) {
X if (Rational(u))
X u = (value) Numerator((rational)u);
X s = u==(value)int_0 ? 0 : Msd((integer)u) < 0 ? -1 : 1;
X } else
X s = Frac((real)u) > 0 ? 1 : Frac((real)u) < 0 ? -1 : 0;
X
X return MkSmallInt(s);
X}
X
X
X/*
X * ~u makes an approximate number of any numerical value.
X */
X
XVisible value approximate(u) value u; {
X if (Approximate(u))
X return Copy(u);
X else if (IsSmallInt(u))
X return (value) mk_approx((double) SmallIntVal(u), 0.0);
X else
X return app_frexp(u);
X}
X
X
X/*
X * exact(v) returns whether a number isn'y approximate
X */
X
XVisible bool exact(v) value v; {
X return (bool) Exact(v);
X}
X
X/*
X * numerator v returns the numerator of v, whenever v is an exact number.
X * For integers, that is v itself.
X */
X
XVisible value numerator(v) value v; {
X if (!Exact(v)) {
X interr(MESS(602, "in */n, n is an approximate number"));
X return zero;
X }
X
X if (Integral(v)) return Copy(v);
X
X return Copy(Numerator((rational)v));
X}
X
X
X/*
X * The denominator of v, whenever v is an exact number.
X * For integers, that is 1.
X */
X
XVisible value denominator(v) value v; {
X if (!Exact(v)) {
X interr(MESS(603, "in /*n, n is an approximate number"));
X return zero;
X }
X
X if (Integral(v)) return one;
X
X return Copy(Denominator((rational)v));
X}
X
X
X/*
X * u root v is defined as v**(1/u), where u is usually but need not be
X * an integer.
X */
X
XVisible value root2(u, v) value u, v; {
X if (u == (value)int_0 ||
X Rational(u) && Numerator((rational)u) == int_0 ||
X Approximate(u) && Frac((real)u) == 0) {
X interr(MESS(604, "in n root x, n is zero"));
X v = Copy(v);
X } else {
X u = quot((value)int_1, u);
X v = power(v, u);
X release(u);
X }
X
X return v;
X}
X
X/* root x is computed more exactly than n root x, by doing
X one iteration step extra. This ~guarantees root(n**2) = n. */
X
XVisible value root1(v) value v; {
X value r, v_over_r, theirsum, result;
X if (numcomp(v, zero) < 0) {
X interr(MESS(605, "in root x, x is negative"));
X return Copy(v);
X }
X r = root2((value)int_2, v);
X if (Approximate(r) && Frac((real)r) == 0.0) return (value)r;
X v_over_r = quot(v, r);
X theirsum = sum(r, v_over_r), release(r), release(v_over_r);
X result = quot(theirsum, (value)int_2), release(theirsum);
X return result;
X}
X
X/* The rest of the mathematical functions */
X
XVisible value pi() { return (value) mk_approx(3.141592653589793238463, 0.0); }
XVisible value e() { return (value) mk_approx(2.718281828459045235360, 0.0); }
X
XHidden real over_two_pi(v) value v; {
X real two_pi = mk_approx(6.283185307179586476926, 0.0);
X real w = (real) approximate(v);
X real res = app_quot(w, two_pi);
X Release(two_pi); Release(w);
X return res;
X}
XHidden value trig(u, v, ffun, zeroflag)
X value u, v;
X mathfun ffun;
X bool zeroflag;
X{
X real w;
X double expo, frac, x, result;
X extern int errno;
X
X
X if (u != Vnil) { /* dyadic version */
X real f = over_two_pi(u);
X real rv = (real) approximate(v);
X w = app_quot(rv, f); /* check on f<>0 (= u<>0) in i3fpr.c */
X Release(f); Release(rv);
X }
X else {
X w = (real) approximate(v);
X }
X expo = Expo(w); frac = Frac(w);
X if (expo <= Minexpo/2) {
X if (zeroflag) return (value) w; /* sin small x = x, etc. */
X frac = 0, expo = 0;
X }
X Release(w);
X if (expo > Maxexpo) errno = EDOM;
X else {
X x = ldexp(frac, (int)expo);
X if (x >= Maxtrig || x <= -Maxtrig) errno = EDOM;
X else {
X errno = 0;
X result = (*ffun)(x);
X }
X }
X if (errno != 0) {
X if (errno == ERANGE)
X interr(MESS(606, "result of math function too large"));
X else if (errno == EDOM)
X interr(MESS(607, "argument to math function too large"));
X else interr(MESS(608, "math library error"));
X return Copy(app_0);
X }
X return (value) mk_approx(result, 0.0);
X}
X
XVisible value sin1(v) value v; { return trig(Vnil, v, sin, Yes); }
XVisible value cos1(v) value v; { return trig(Vnil, v, cos, No); }
XVisible value tan1(v) value v; { return trig(Vnil, v, tan, Yes); }
XVisible value sin2(u, v) value u, v; { return trig(u, v, sin, Yes); }
XVisible value cos2(u, v) value u, v; { return trig(u, v, cos, No); }
XVisible value tan2(u, v) value u, v; { return trig(u, v, tan, Yes); }
X
XVisible value arctan1(v) value v; {
X real w = (real) approximate(v);
X double expo = Expo(w), frac = Frac(w);
X if (expo <= Minexpo + 2) return (value) w; /* atan of small x = x */
X Release(w);
X if (expo > Maxexpo) expo = Maxexpo;
X return (value) mk_approx(atan(ldexp(frac, (int)expo)), 0.0);
X}
X
XVisible value arctan2(u, v) value u, v; {
X real av = (real) arctan1(v);
X real f = over_two_pi(u);
X real r = app_prod(av, f);
X Release(av); Release(f);
X return (value) r;
X}
X
XHidden double atn2(x, y) double x, y; {
X if (x == 0.0 && y == 0.0)
X return 0.0;
X else
X return atan2(x, y);
X}
X
XVisible value angle1(u, v) value u, v; {
X real ru = (real) approximate(u), rv = (real) approximate(v);
X double uexpo = Expo(ru), ufrac = Frac(ru);
X double vexpo = Expo(rv), vfrac = Frac(rv);
X Release(ru), Release(rv);
X if (uexpo > Maxexpo) uexpo = Maxexpo;
X if (vexpo > Maxexpo) vexpo = Maxexpo;
X return (value) mk_approx(
X atn2(
X vexpo < Minexpo ? 0.0 : ldexp(vfrac, (int)vexpo),
X uexpo < Minexpo ? 0.0 : ldexp(ufrac, (int)uexpo)),
X 0.0);
X}
X
XVisible value angle2(c, u, v) value c, u, v; {
X real av = (real) angle1(u, v);
X real f = over_two_pi(c);
X real r = app_prod(av, f);
X Release(av); Release(f);
X return (value) r;
X}
X
XVisible value radius(u, v) value u, v; {
X real x = (real) approximate(u);
X real y = (real) approximate(v);
X real x2 = app_prod(x, x);
X real y2 = app_prod(y, y);
X real x2y2 = app_sum(x2, y2);
X value rad = root1((value) x2y2);
X Release(x); Release(y);
X Release(x2); Release(y2); Release(x2y2);
X return rad;
X}
X
XVisible value exp1(v) value v; {
X real w = (real) approximate(v);
X real x = app_exp(w);
X Release(w);
X return (value) x;
X}
X
XVisible value log1(v) value v; {
X real w, x;
X if (numcomp(v, zero) <= 0) {
X interr(MESS(609, "in log x, x <= 0"));
X return copy(zero);
X }
X w = (real) approximate(v);
X x = app_log(w);
X Release(w);
X return (value) x;
X}
X
XVisible value log2(u, v) value u, v;{
X value w;
X if (numcomp(u, zero) <= 0) {
X interr(MESS(610, "in b log x, b <= 0"));
X return copy(zero);
X }
X if (numcomp(v, zero) <= 0) {
X interr(MESS(611, "in b log x, x <= 0"));
X return copy(zero);
X }
X u = log1(u);
X v = log1(v);
X w = quot(v, u);
X release(u), release(v);
X return w;
X}
X
X/* exactly() converts a approximate number to an exact number */
X
XVisible value exactly(v) value v; {
X if (exact(v))
X return Copy(v);
X else
X return app_exactly((real) v);
X}
END_OF_FILE
if test 16456 -ne `wc -c <'abc/bint1/i1fun.c'`; then
echo shar: \"'abc/bint1/i1fun.c'\" unpacked with wrong size!
fi
# end of 'abc/bint1/i1fun.c'
fi
if test -f 'abc/ch_config' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'abc/ch_config'\"
else
echo shar: Extracting \"'abc/ch_config'\" \(230 characters\)
sed "s/^X//" >'abc/ch_config' <<'END_OF_FILE'
X: 'Check if we are cross compiling'
X
Xcase $1 in
X'') exit 0;;
X*) echo "Please compile and run mkconfig on the destination machine"
X echo "and copy the results to ./$2."
X echo "Then call 'make all install'"
X echo " "
X exit 1;;
Xesac
END_OF_FILE
if test 230 -ne `wc -c <'abc/ch_config'`; then
echo shar: \"'abc/ch_config'\" unpacked with wrong size!
fi
chmod +x 'abc/ch_config'
# end of 'abc/ch_config'
fi
echo shar: End of archive 10 \(of 25\).
cp /dev/null ark10isdone
MISSING=""
for I in 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 ; do
if test ! -f ark${I}isdone ; then
MISSING="${MISSING} ${I}"
fi
done
if test "${MISSING}" = "" ; then
echo You have unpacked all 25 archives.
rm -f ark[1-9]isdone ark[1-9][0-9]isdone
else
echo You still must unpack the following archives:
echo " " ${MISSING}
fi
exit 0 # Just in case...
--
Please send comp.sources.unix-related mail to rsalz at uunet.uu.net.
Use a domain-based address or give alternate paths, or you may lose out.
More information about the Comp.sources.unix
mailing list