├── .gitignore ├── Makefile.in ├── README ├── autoconf ├── DESIGN ├── configure ├── configure.in └── install-sh ├── configure ├── docs ├── Copyright ├── GPL ├── License.original ├── README ├── install_guide │ ├── Installation │ ├── editors │ ├── pagers │ ├── printer │ └── terminals ├── project │ ├── Announce │ ├── BugList │ ├── Credits │ ├── Resources │ ├── Support │ ├── ToDo │ ├── WhatsNew │ └── openapl.lsm └── user_guide │ ├── IBeams │ ├── Printing │ ├── QuadFunc │ ├── QuadVar │ ├── README │ ├── Readline │ ├── SandBox │ ├── SysCommands │ ├── UserFunc │ └── WorkSpaces ├── qa ├── DESIGN ├── Makefile.in ├── clean_dir │ ├── exp │ ├── lemming │ ├── makeN.ws │ ├── nilret1 │ ├── onearg │ ├── pfoo │ ├── twoargs │ ├── ulam.ws │ └── withret1 ├── encode.inp ├── encode.ref ├── errors.inp ├── errors.ref ├── format.inp ├── format.ref ├── makeN.ws ├── mixed_dyadic.inp ├── mixed_dyadic.ref ├── mixed_monadic.inp ├── mixed_monadic.ref ├── printing.inp ├── printing.ref ├── quad_fx.inp ├── quad_fx.ref ├── quad_vars.ref ├── quad_vars.sh ├── quad_vars.stdin ├── scalar_dyadic.inp ├── scalar_dyadic.ref ├── scalar_monadic.inp ├── scalar_monadic.ref ├── struct_dyadic.inp ├── struct_dyadic.ref ├── struct_monadic.inp ├── struct_monadic.ref ├── trig.inp ├── trig.ref ├── ulam.ws ├── userfunc_nilret1.inp ├── userfunc_nilret1.ref ├── userfunc_onearg1.inp ├── userfunc_onearg1.ref ├── userfunc_shadow2.inp ├── userfunc_shadow2.ref ├── userfunc_shadow_arg.inp ├── userfunc_shadow_arg.ref ├── userfunc_shadow_globals.inp ├── userfunc_shadow_globals.ref ├── userfunc_shadow_undefined.inp ├── userfunc_shadow_undefined.ref ├── userfunc_stdin.inp ├── userfunc_stdin.ref ├── userfunc_t1.inp ├── userfunc_t1.ref ├── userfunc_twoargs1.inp ├── userfunc_twoargs1.ref ├── userfunc_withret1.inp └── userfunc_withret1.ref └── source ├── Docs ├── Internals └── global_replace ├── Makefile ├── data ├── DESIGN ├── Makefile ├── access.c ├── bidx.c ├── colapse.c ├── copy.c ├── data_iterator.c ├── dupdat.c ├── erase.c ├── fetch.c ├── getdata.c ├── newdat.c ├── nlook.c ├── pop.c ├── putdat.c ├── rbtree.c ├── rbtree.h ├── s2vect.c ├── size.c ├── symtab.c └── top.c ├── debug ├── DESIGN ├── Makefile ├── code_dump.c ├── mem_dump.c ├── parsedump.c ├── stack_dump.c └── vars_dump.c ├── execute ├── Makefile ├── ex_botch.c ├── ex_cdyad.c ├── ex_ddyad.c ├── ex_dscal.c ├── ex_mdyad.c └── execute.c ├── format ├── Makefile ├── ex_dfmt.c ├── ex_mfmt.c ├── fp2char.c ├── fp2char_paded.c ├── fp_dfmt.c ├── fp_digits.c └── fp_mfmt.c ├── ibeam ├── Makefile ├── ex_dibm.c └── ex_mibm.c ├── include ├── apl.h ├── ascii_input.h ├── char.h ├── config.h.in ├── data.h ├── debug.h ├── execute.h ├── format.h ├── getinput.h ├── main.h ├── makefile.common.in ├── memory.h ├── mixed_dyadic.h ├── mixed_monadic.h ├── oper_dyadic.h ├── opt_codes.h ├── parser.h ├── print.h ├── quad_func.h ├── quad_var.h ├── userfunc.h ├── utility.h ├── version.h └── work_space.h ├── main ├── DESIGN.Context ├── Makefile ├── apl.c ├── ascii_input.c ├── exit.c ├── getinput.c ├── history.c ├── history.h └── mainloop.c ├── memory ├── DESIGN ├── Makefile ├── afreset.c ├── alloc.c ├── aplfree.c └── memory.c ├── mixed_dyadic ├── Makefile ├── ex_base.c ├── ex_ddom.c ├── ex_deal.c ├── ex_diot.c ├── ex_eps.c ├── ex_index.c ├── ex_rep.c ├── ex_rot.c ├── ex_tak_drp.c └── ex_trn.c ├── mixed_monadic ├── Makefile ├── ex_execute.c ├── ex_gdd.c ├── ex_gdu.c ├── ex_mdom.c ├── ex_menc.c ├── ex_rand.c ├── ex_rev.c ├── gd.c └── gd.h ├── oper_dyadic ├── Makefile ├── ex_asgn.c ├── ex_iprod.c └── ex_oprod.c ├── oper_monadic ├── Makefile ├── ex_com.c ├── ex_exd.c ├── ex_red.c └── ex_scan.c ├── parser ├── Makefile ├── alpha.c ├── alpha.h ├── apl.y ├── apl.y.original ├── compile_new.c ├── compile_old.c ├── digit.c ├── font_map.c ├── genlab.c ├── getnam.c ├── getnum.c ├── getquad.c ├── invert.c ├── lastcode.c ├── local_parser.c ├── local_parser.h ├── name.c ├── table_comm.c ├── table_oper.c ├── table_quad.c ├── y.tab.c ├── y.tab.h ├── yyerror.c └── yylex.c ├── print ├── DESIGN ├── Makefile ├── c_overbar.c ├── ex_hprint.c ├── ex_print.c ├── fp_print.c ├── local_print.h ├── lt_print.c ├── print.c └── print_line.c ├── quad_func ├── Makefile ├── eval_qlx.c ├── ex_ap.c ├── ex_chdir.c ├── ex_close.c ├── ex_create.c ├── ex_crp.c ├── ex_dup.c ├── ex_ex.c ├── ex_exec.c ├── ex_exit.c ├── ex_fdef.c ├── ex_float.c ├── ex_fork.c ├── ex_kill.c ├── ex_nc.c ├── ex_nl.c ├── ex_open.c ├── ex_pipe.c ├── ex_rd.c ├── ex_read.c ├── ex_run.c ├── ex_seek.c ├── ex_signl.c ├── ex_unlink.c ├── ex_wait.c ├── ex_write.c └── iofname.c ├── quad_var ├── Makefile ├── ex_qai.c ├── ex_qargv.c ├── ex_qav.c ├── ex_qct.c ├── ex_qio.c ├── ex_qlx.c ├── ex_qpp.c ├── ex_qpw.c ├── ex_qquad.c ├── ex_qts.c └── ex_quad.c ├── scalar_dyadic ├── Makefile ├── ex_add.c ├── ex_and.c ├── ex_cir.c ├── ex_comb.c ├── ex_div.c ├── ex_eq.c ├── ex_ge.c ├── ex_gt.c ├── ex_le.c ├── ex_log.c ├── ex_lt.c ├── ex_max.c ├── ex_min.c ├── ex_minus.c ├── ex_mod.c ├── ex_mul.c ├── ex_nand.c ├── ex_ne.c ├── ex_nor.c ├── ex_or.c ├── ex_plus.c ├── ex_pwr.c └── ex_sub.c ├── scalar_monadic ├── Makefile ├── ex_abs.c ├── ex_ceil.c ├── ex_exp.c ├── ex_fac.c ├── ex_floor.c ├── ex_loge.c ├── ex_not.c ├── ex_pi.c ├── ex_recip.c └── ex_sgn.c ├── struct_dyadic ├── Makefile ├── ex_cat.c └── ex_drho.c ├── struct_monadic ├── Makefile ├── ex_miot.c ├── ex_mrho.c └── ex_rav.c ├── sys_command ├── Makefile ├── ex_list.c ├── ex_list.h ├── ex_prws.c ├── ex_prws.h ├── ex_shell.c ├── ex_shell.h ├── ex_syscom.c ├── listdir.c └── listdir.h ├── userfunc ├── DESIGN ├── Makefile ├── context.c ├── csize.c ├── ex_arg1.c ├── ex_arg2.c ├── ex_auto.c ├── ex_br.c ├── ex_br0.c ├── ex_fun.c ├── ex_ibr.c ├── ex_ibr0.c ├── ex_label.c ├── ex_nilret.c ├── ex_rest.c ├── funcomp.c ├── fundef.c ├── funedit.c ├── funread.c ├── funstdin.c ├── funwrite.c ├── sichk.c └── tback.c ├── utility ├── Makefile ├── checksp.c ├── errors.c ├── extend.c ├── fappend.c ├── file.c ├── fix.c ├── floating.c ├── fuzz.c ├── gamma.c ├── iodone.c ├── map.c ├── optable.c ├── readline.c ├── scalar.c ├── signals.c └── topfix.c └── work_space ├── Makefile ├── fdat.c ├── fdat.h ├── ws_clear.c ├── ws_load.c └── ws_save.c /.gitignore: -------------------------------------------------------------------------------- 1 | *.o 2 | apl 3 | rline 4 | aplws.abort 5 | /Makefile 6 | qa/Makefile 7 | source/aplette 8 | source/include/config.h 9 | source/include/makefile.common 10 | autoconf/config.cache 11 | autoconf/config.log 12 | autoconf/config.status 13 | printer/apl2epson 14 | printer/apl2gs 15 | script/apl-setup 16 | script/aplrc 17 | qa/*.dif 18 | qa/*.dif2 19 | qa/*.out 20 | -------------------------------------------------------------------------------- /README: -------------------------------------------------------------------------------- 1 | Welcome to aplette 2 | ------------------ 3 | Aplette is a slimmed down, skinny APL interpreter derived from openApl. 4 | 5 | On linux, you will need to install bison and libreadline. 6 | 7 | For example, on Ubuntu: 8 | sudo apt-get install bison 9 | sudo apt-get install libreadline8 libreadline-dev bison 10 | 11 | annoyingly, libreadline keeps getting renamed, with new numbers. 12 | You may need to do something like the following to find the current 13 | version of libreadline: 14 | 15 | apt list 2> /dev/null | egrep 'libreadline[0-9]/' 16 | 17 | On Windows, I have tested with cygwin only. In your cygwin installation, 18 | you will need to include gcc, gnu make, libreadline_devel, and bison. 19 | 20 | To build: 21 | $> ./configure 22 | $> make 23 | 24 | This will build the binary executable source/aplette. 25 | 26 | You can test your installation as follows: 27 | $> cd qa 28 | $> make 29 | 30 | 31 | aplette uses an ASCII/APL character mapping dubbed APL-touchtype. 32 | The command ")font" will print the APL-touchtype characters in 33 | tabular form. 34 | 35 | If you can write APL with your eyes closed, you can use 36 | APL-touchtype. "rho" is "R", "iota" is "I", etc. Trig is "O". Log is 37 | "O@*". (APL-touchtype uses "@" instead of backspace, and with that trivial 38 | substitution, all of the APL overstrikes become APL-touchtype ascii.) 39 | -------------------------------------------------------------------------------- /configure: -------------------------------------------------------------------------------- 1 | #! /bin/sh 2 | ## This is a BOGUS configure script! 3 | ## The REAL configure script is in the autoconf directory 4 | ## (where the log and cache files are concealed). 5 | args='' 6 | 7 | ## Uncomment and edit the following to change prefix from /usr/local 8 | #args="$args --prefix=/usr" 9 | 10 | ## Uncomment and edit the following to change configuration 11 | ## directory from $prefix/etc 12 | #args="$args --sysconfdir=/etc" 13 | 14 | ## You would uncomment the previous two options in order to install 15 | ## aplette according to the Linux File System Standard. If that is 16 | ## your goal, then leave the next group alone. 17 | 18 | ## STOP no more user options below this point. 19 | cd autoconf 20 | ./configure $args $* 21 | -------------------------------------------------------------------------------- /docs/Copyright: -------------------------------------------------------------------------------- 1 | openAPL, Copyright (C) Branko Bratkovic 1998 2 | 3 | This program is distributed in the hope that it will be useful, 4 | but WITHOUT ANY WARRANTY; without even the implied warranty of 5 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. 6 | 7 | openAPL is free software and is covered by the GNU General 8 | Public License; for more details see the file "GPL". 9 | 10 | ---------------------------------------------------------- 11 | openAPL is based on apl\11. Conditions of use for apl\11 are 12 | described in the file "License.original" which provides for 13 | apl\11 to be sublicensed. apl\11 has been modified to create 14 | openAPL which has been sublicensed with the additional 15 | provisions of the GPL applied. 16 | 17 | The copyright holder for apl\11 is: 18 | 19 | U S WEST Advanced Technologies 20 | 4001 Discovery Drive, Boulder, Colorado, 80303 21 | 22 | ---------------------------------------------------------- 23 | The owners and origins of the fonts that were used in the 24 | integration of apl\11 onto the Linux console and into X11 25 | are described in the file "project/Credits". 26 | 27 | ---------------------------------------------------------- 28 | The Postscript(TM) file apl2741.fnt is subject to a copyright 29 | that prevents it being modified. 30 | 31 | -------------------------------------------------------------------------------- /docs/install_guide/pagers: -------------------------------------------------------------------------------- 1 | 2 | FILE PAGERS KNOWN TO WORK WITH APL2741 ENCODING 3 | ----------------------------------------------- 4 | One would not normally want to page APL files under an 5 | openAPL session. However, functions can be written out 6 | to unix files; some of the documentation and all of the QA 7 | test files are encoded in APL2741 so the use of a pager 8 | can be convient at times. Note: in order to to use a pager 9 | to view APL2741 encoding, you should be running a shell 10 | inside an emulated APL terminal, ie following the command: 11 | 12 | $> apl -on 13 | 14 | more 15 | ---- 16 | The classic Unix pager "more" does not attempt to change the 17 | 8th bit which is used to represent APL characters. That is, 18 | it displays raw characters and so is suitable for viewing 19 | APL2741 encoded files. 20 | Tested on version 5.19 (Berkeley) 6/29/88 on a Debian system. 21 | 22 | less 23 | ---- 24 | The more clone "less" can be made to display raw characters 25 | with the option -r. Ease of use can be improved by setting 26 | the environment variable LESS to include this option. 27 | Tested on version 332 28 | 29 | -- 30 | This file is subject to the restrictions and privileges of the 31 | GNU General Public License. 32 | -------------------------------------------------------------------------------- /docs/project/ToDo: -------------------------------------------------------------------------------- 1 | To Do List, version 0.0 2 | ----------------------- 3 | This list describes what I intend to get done during the ALPHA testing 4 | period. The overall goal is to create a useable APL for GNU/Linux - 5 | diversions for enhancements will be resisted. The list is in 6 | approximate priority order (highest first), however, it could change 7 | in response to something that the ALPHA testers may discover. 8 | -- 9 | Branko 10 | 11 | List begins: 12 | Rewrite the Quality Assurance (QA) scripts to cover as much APL 13 | as possible. 14 | 15 | Improve error reporting beyond the parser. Refer BugList(008) 16 | 17 | Introduce )WSID system function 18 | 19 | Adapt the parser to enable system functions to use variable 20 | length argument lists. Refer BugList(006) 21 | 22 | Create )IMPORT and )EXPORT system functions to deal with 23 | APLASCII and )IN )OUT to deal with *.ATF files. 24 | 25 | Download computer based training from the waterloo site, 26 | import into openAPL and test. 27 | 28 | Introduce a plotting function: possibly shelling out to gnuplot. 29 | 30 | Create the quad expunge function (QuadEX) from existing )erase code. 31 | -------------------------------------------------------------------------------- /docs/project/openapl.lsm: -------------------------------------------------------------------------------- 1 | 2 | Begin3 3 | Title: openAPL 4 | Version: 0.14 5 | Entered-date: 01MAY00 6 | Description: A Programming Language (APL) allows the user 7 | to manipulate multi-dimensional arrays through 8 | a grammar that uses special character symbols 9 | to represent functions and operators. openAPL 10 | is a package that provides the special APL font 11 | plus some enhancements for APL\11 - a very old 12 | version of APL. Both the Linux console and X11 13 | can be used to host this font. 14 | This is an ALPHA version. 15 | Keywords: apl APL array vector matrix 16 | Author: 17 | Maintained-by: see the Support file 18 | Primary-site: metalab.unc.edu /pub/Linux/devel/lang/apl 19 | 319k openapl-0.13.tar.gz 20 | Alternate-site: 21 | Original-site: 22 | Platforms: Linux console - requires kbd package 23 | X11 - requires specially compiled rxvt 24 | Postscript printer - requires a2gs 25 | Epson printer - requires fontprint 26 | Copying-policy: GPL 27 | End 28 | -------------------------------------------------------------------------------- /docs/user_guide/IBeams: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/gregfjohnson/aplette/cc5009c197b182cbe3d3cc32a35594ced0bf9729/docs/user_guide/IBeams -------------------------------------------------------------------------------- /docs/user_guide/Printing: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/gregfjohnson/aplette/cc5009c197b182cbe3d3cc32a35594ced0bf9729/docs/user_guide/Printing -------------------------------------------------------------------------------- /docs/user_guide/QuadFunc: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/gregfjohnson/aplette/cc5009c197b182cbe3d3cc32a35594ced0bf9729/docs/user_guide/QuadFunc -------------------------------------------------------------------------------- /docs/user_guide/QuadVar: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/gregfjohnson/aplette/cc5009c197b182cbe3d3cc32a35594ced0bf9729/docs/user_guide/QuadVar -------------------------------------------------------------------------------- /docs/user_guide/README: -------------------------------------------------------------------------------- 1 | Some of the files in this directory contain characters 2 | encoded for apl2741 font (specifically the files QuadVars 3 | and QuadFunc). 4 | 5 | In order to see the APL characters properly, use the command 6 | "apl -on" then view the file with an 8-bit clean pager or 7 | editor. Advice on 8-bit clean programs can be found in the 8 | install_guide directory. 9 | 10 | -------------------------------------------------------------------------------- /docs/user_guide/Readline: -------------------------------------------------------------------------------- 1 | In order for readline to work, you need to have a ~/.inputrc 2 | file that contains the following: 3 | 4 | $if openapl 5 | set editing-mode emacs 6 | set convert-meta off 7 | set input-meta on 8 | set output-meta on 9 | $endif 10 | 11 | (You can 'set editing-mode vi' if preferred.) 12 | 13 | If the apl script detects an .inputrc file it will pass -r to 14 | apl11 which will then use readline during execution. 15 | 16 | If your .inputrc file does not have the above but you include -r 17 | on the command line, then the special APL characters will not work. 18 | 19 | -------------------------------------------------------------------------------- /docs/user_guide/SandBox: -------------------------------------------------------------------------------- 1 | SandBox Mode 2 | ----------- 3 | 4 | SandBox Mode is an attempt to reduce the risk of damage to external files by 5 | hostile programs. 6 | 7 | SandBox mode becomes active when: 8 | 1. the -s flag is provided in the argument list when apl11 is invoked. 9 | 2. Quad LX (Latent eXpression) is executed through the )load command 10 | 11 | Situation 2. is the main reason for the existence of SandBox mode, it is 12 | intended to be a defense against macro style viruses. However, it should 13 | not be regarded as total security by users who receive APL programs from 14 | outside their control. It does not prevent a user run program from 15 | doing damage after being started by a legitimate method, ie 'Trojan Horse' 16 | attack. Furthermore, damage within the user's workspace should not be 17 | dismissed as trivial (which SandBox mode does not guard against). 18 | 19 | By design, SandBox mode cannot be tested or set within a session. This is 20 | intended to prevent a hostile program from adjusting its behaviour: 21 | once a prohibited operation is attempted during SandBox mode, control is 22 | returned to the user. 23 | 24 | OpenAPL could be set up by the administrator to run in SandBox mode by 25 | putting -s on the argument list in /etc/apl.sh. This would be easy to 26 | bypass. Slightly more confidence could be had by editing apl.c, to 27 | set sandboxflg to 1 and recompiling. 28 | 29 | Nobody can guarantee that openAPL or APL/11 is, or can be made, secure. 30 | The contributers and developers of this package do not accept any 31 | responsibility for loss and/or damage caused by the use of this package 32 | by anyone at all. 33 | 34 | -------------------------------------------------------------------------------- /docs/user_guide/WorkSpaces: -------------------------------------------------------------------------------- 1 | 2 | Workspaces are simply UNIX data files. The name of the 3 | workspace is the same as the file name. 4 | 5 | A saved workspace includes function definitions and 6 | variables. If there are suspended functions, all of the 7 | local variables for those functions are also saved. 8 | However, the APL state indicator is not saved, so that those 9 | variables become global in scope when the saved workspace is 10 | loaded. Trying to save the state indicator is very hard in 11 | the current version of the interpreter because of the way 12 | the main program loop is implemented. 13 | 14 | The first time you run apl, a directory named "apl" will 15 | be created in your $HOME directory, this contains the 16 | workspace "continue" which is in turn automatically loaded 17 | on startup - it displays the copyright message. Delete the 18 | file "continue" when you have had enough of it; however, 19 | the "apl" directory in your $HOME directory should remain as 20 | a place to keep openAPL workspaces. 21 | 22 | -------------------------------------------------------------------------------- /qa/Makefile.in: -------------------------------------------------------------------------------- 1 | # Makefile for for testing aplette 2 | 3 | # point to the just built copy (not the installed version) 4 | APLEXE = ../source/aplette 5 | 6 | DIFF = @diff@ 7 | 8 | OBJECTS = printing.dif quad_vars.dif2 \ 9 | format.dif trig.dif errors.dif \ 10 | scalar_monadic.dif scalar_dyadic.dif \ 11 | mixed_monadic.dif mixed_dyadic.dif \ 12 | struct_monadic.dif struct_dyadic.dif \ 13 | userfunc_nilret1.dif userfunc_twoargs1.dif \ 14 | userfunc_onearg1.dif userfunc_withret1.dif \ 15 | userfunc_stdin.dif \ 16 | userfunc_shadow_arg.dif \ 17 | userfunc_shadow_globals.dif \ 18 | userfunc_shadow_undefined.dif \ 19 | userfunc_shadow2.dif \ 20 | userfunc_t1.dif \ 21 | quad_fx.dif encode.dif \ 22 | 23 | # Keep *.out files 24 | .PRECIOUS: %.out 25 | 26 | # As long as the following is the first target, 27 | # everything will get tested 28 | all: $(OBJECTS) 29 | 30 | %.dif: %.out 31 | $(DIFF) $< $*.ref > $@ 32 | 33 | %.out: %.inp $(APLEXE) 34 | $(APLEXE) < $< | sed -e 's/[0-9][0-9]:[0-9][0-9]\.[0-9][0-9] [0-9][0-9]\/[0-9][0-9]\/[0-9][0-9]/hh:mm.ss mm\/dd\/yy/' > $@ 35 | echo >> $@ 36 | 37 | # This test is separate, because it requires a special input 38 | # file and runs an aplette script. 39 | quad_vars.dif2: quad_vars.sh 40 | ./quad_vars.sh < quad_vars.stdin > quad_vars.out 41 | $(DIFF) quad_vars.out quad_vars.ref > $@ 42 | 43 | clean: 44 | rm -f *.dif *.dif2 *.out aplws.abort clean_dir/aplws.abort \ 45 | clean_dir/core.* core.* 46 | -------------------------------------------------------------------------------- /qa/clean_dir/exp: -------------------------------------------------------------------------------- 1 | G z { exp x; xreal; ximag; rz 2 | } ((0 # RRx) ^ 1 # `1 Y Rx) / xnotreal 3 | x { x, 0 4 | xnotreal: 5 | rz { Rx 6 | xreal { 0 `1 U ((X/`1URx), 2) Rx 7 | ximag { 0 1 U ((X/`1URx), 2) Rx 8 | z { rz R ((*xreal) X (2 O ximag)), (*xreal) X 1 O ximag 9 | -------------------------------------------------------------------------------- /qa/clean_dir/lemming: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/gregfjohnson/aplette/cc5009c197b182cbe3d3cc32a35594ced0bf9729/qa/clean_dir/lemming -------------------------------------------------------------------------------- /qa/clean_dir/makeN.ws: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/gregfjohnson/aplette/cc5009c197b182cbe3d3cc32a35594ced0bf9729/qa/clean_dir/makeN.ws -------------------------------------------------------------------------------- /qa/clean_dir/nilret1: -------------------------------------------------------------------------------- 1 | G nilret1; lcl1 2 | l1: lcl1 { 47 3 | l2: a { 10 4 | l3: a % 10 5 | -------------------------------------------------------------------------------- /qa/clean_dir/onearg: -------------------------------------------------------------------------------- 1 | G z { onearg x 2 | z { x * x 3 | -------------------------------------------------------------------------------- /qa/clean_dir/pfoo: -------------------------------------------------------------------------------- 1 | G z { u pfoo v 2 | u 3 | v 4 | z { 'xx' 5 | -------------------------------------------------------------------------------- /qa/clean_dir/twoargs: -------------------------------------------------------------------------------- 1 | G z { n twoargs x 2 | z { n * x 3 | -------------------------------------------------------------------------------- /qa/clean_dir/ulam.ws: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/gregfjohnson/aplette/cc5009c197b182cbe3d3cc32a35594ced0bf9729/qa/clean_dir/ulam.ws -------------------------------------------------------------------------------- /qa/clean_dir/withret1: -------------------------------------------------------------------------------- 1 | G z { withret1 2 | z { 10 3 | z { z % 100 4 | -------------------------------------------------------------------------------- /qa/encode.inp: -------------------------------------------------------------------------------- 1 | (3R2) N `1 + I8 2 | -------------------------------------------------------------------------------- /qa/encode.ref: -------------------------------------------------------------------------------- 1 | 0 0 0 0 1 1 1 1 2 | 0 0 1 1 0 0 1 1 3 | 0 1 0 1 0 1 0 1 4 | 5 | -------------------------------------------------------------------------------- /qa/errors.inp: -------------------------------------------------------------------------------- 1 | z { 1 2 | + 3 | x x 4 | 5 | -------------------------------------------------------------------------------- /qa/errors.ref: -------------------------------------------------------------------------------- 1 | + 2 | Syntax Error. 3 | x x 4 | Syntax Error. 5 | 6 | -------------------------------------------------------------------------------- /qa/format.inp: -------------------------------------------------------------------------------- 1 | 'Monadic Format (character "downtack jot")' 2 | Lpp { 10 3 | '|',(J@N 5 `6 7 8 9 10J.%I5),'|' 4 | d { 0.7 0.8 0.9, 7 8 9%10 5 | J@N d 6 | d - B@J J@N d 7 | Lpp { 20 8 | J@N d 9 | d - B@J J@N d 10 | Lpp { 4 11 | m { 0.78901 X (10*I6) J.X 1 1e`10 1e`6 0.01 0.1 12 | J@N m 13 | J@N 5 R m 14 | J@N 1 5 R m 15 | 16 | '\nDyadic Format' 17 | 20 `7 J@N O 1 18 | 20 `7 J@N - O 1 19 | d { `1 `0.1 0 0.1 1 J.X 5 R 0.5 20 | e { 9 `3 7 `1 6 3 5 1 3 0 21 | e J@N d 22 | e J@N -d 23 | e J@N d X 100 24 | e J@N -d X .0001 25 | 26 | R 1 0 2 0 4 0 8 0 J@N 0 4 R 1 27 | 4 1 J@N `.99 `.89 0 7.5 11.5 28 | 29 | '\nNon-fitting formats' 30 | L { a { (`1+I5) J.% I 4 31 | 7 `2 J@N a 32 | 7 `3 J@N a 33 | 7 `4 J@N a 34 | 35 | 7 4 J@N a 36 | 7 5 J@N a 37 | 7 6 J@N 100 X a 38 | 10 4J@N 100 X a 39 | 40 | -------------------------------------------------------------------------------- /qa/makeN.ws: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/gregfjohnson/aplette/cc5009c197b182cbe3d3cc32a35594ced0bf9729/qa/makeN.ws -------------------------------------------------------------------------------- /qa/mixed_dyadic.inp: -------------------------------------------------------------------------------- 1 | 'Join along an axis' 2 | L { m { 2 3 R 'H' 3 | L { h { 3 3 R 'O' 4 | m,[1]h 5 | L { l { 2 4 R 'L' 6 | m,l 7 | m,'+' 8 | m,'34' 9 | m,[1]'345' 10 | a { 3 4RI12 11 | R L { a,3 0R99 12 | 13 | '\nLaminate' 14 | 1 2 3,[.5] 4 5 6 15 | 1 2 3,[1.5] 4 5 6 16 | 1 2 3,[1.5]4 17 | 18 | '\nBase' 19 | 10 B 1 2 3 20 | 24 60 60 B 1 2 3 21 | L { a { 2 3 R 10 10 10 12 60 60 22 | L { b { 3 2 R 1 4 2 5 3 6 23 | a B b 24 | `.001 10 10 B 1 2 3 25 | 60 B 1 2 3 26 | '' B 3 27 | 'A' B I 0 28 | 29 | '\nLeast squares' 30 | m { 3 2 R 1 0 1 1 0 0 31 | 1 2 3 L@% m 32 | 33 | '\nMixed types - not supported' 34 | (2 0 R 5), 'A' 35 | 3, [.5] '' 36 | 37 | pi { 3 1 4 1 5 9 2 6 38 | left { 1 39 | right { -1 40 | left -@O pi 41 | right -@O pi 42 | 43 | 3 Y pi 44 | 0 Y pi 45 | R 0 Y pi 46 | R R 0 Y pi 47 | 48 | m { 3 4 R I 12 49 | L { m1 { 2 1 U m 50 | Rm1 51 | RRm1 52 | 53 | L { m0 { 1 2 U m1 54 | R m0 55 | R R m0 56 | -------------------------------------------------------------------------------- /qa/mixed_dyadic.ref: -------------------------------------------------------------------------------- 1 | Join along an axis 2 | HHH 3 | HHH 4 | OOO 5 | OOO 6 | OOO 7 | HHH 8 | HHH 9 | OOO 10 | OOO 11 | OOO 12 | LLLL 13 | LLLL 14 | HHHLLLL 15 | HHHLLLL 16 | HHH+ 17 | HHH+ 18 | HHH3 19 | HHH4 20 | HHH 21 | HHH 22 | 345 23 | 1 2 3 4 24 | 5 6 7 8 25 | 9 10 11 12 26 | 3 4 27 | 28 | Laminate 29 | 1 2 3 30 | 4 5 6 31 | 1 4 32 | 2 5 33 | 3 6 34 | 1 4 35 | 2 4 36 | 3 4 37 | 38 | Base 39 | 123 40 | 3723 41 | 10 10 10 42 | 12 60 60 43 | 1 4 44 | 2 5 45 | 3 6 46 | Rank Error: base - cannot handle left-arg-rank > 1. 47 | 123 48 | 3723 49 | Domain Error: base - incorrect types. 50 | Domain Error: base - incorrect types. 51 | 52 | Least squares 53 | 1 1 54 | 55 | Mixed types - not supported 56 | Domain Error. 57 | Domain Error. 58 | 1 4 1 5 9 2 6 3 59 | 6 3 1 4 1 5 9 2 60 | 3 1 4 61 | 62 | 0 63 | 1 64 | 10 11 12 65 | 1 3 66 | 2 67 | 68 | 0 1 69 | 2 70 | 71 | -------------------------------------------------------------------------------- /qa/mixed_monadic.inp: -------------------------------------------------------------------------------- 1 | 'Execute ordinary expressions' 2 | B@J '3 4RI12' 3 | B@J '1+(2X3)' 4 | 5 | '\nNested execute' 6 | B@J '2 + B@J ''1+(2X3)'' ' 7 | n { '1+(2X3)' 8 | B@J '2X B@J n' 9 | 10 | '\nExecute with local variables' 11 | a { 1 12 | b { 2 13 | 14 | B@J 'a { 3' 15 | B@J 'c { 4' 16 | a ; b ; c 17 | 18 | '\nExecute quad variables' 19 | B@J 'Lpp' 20 | B@J 'Lpw { 70' 21 | Lpp 22 | Lpw 23 | 24 | '\nSort via grade up and grade down' 25 | pi { 3 1 4 1 5 9 2 6 26 | pi[ A@| pi ] 27 | pi[ V@| pi ] 28 | 29 | '\nMatrix inverse' 30 | m { (I3) J.<@= I3 31 | minv { L@% m 32 | 8 1 J@N L@% m 33 | -------------------------------------------------------------------------------- /qa/mixed_monadic.ref: -------------------------------------------------------------------------------- 1 | Execute ordinary expressions 2 | 1 2 3 4 3 | 5 6 7 8 4 | 9 10 11 12 5 | 7 6 | 7 | Nested execute 8 | 9 9 | 14 10 | 11 | Execute with local variables 12 | 3 13 | 4 14 | 324 15 | 16 | Execute quad variables 17 | 9 18 | 70 19 | 9 20 | 70 21 | 22 | Sort via grade up and grade down 23 | 1 1 2 3 4 5 6 9 24 | 9 6 5 4 3 2 1 1 25 | 26 | Matrix inverse 27 | 1.0 `1.0 0.0 28 | 0.0 1.0 `1.0 29 | 0.0 0.0 1.0 30 | 31 | -------------------------------------------------------------------------------- /qa/printing.inp: -------------------------------------------------------------------------------- 1 | 'Integers' 2 | a { 1 100 5000 123456789 `2 `400 3 | a 4 | a*2 5 | 6 | '\nReal Numbers' 7 | %a 8 | 9 | '\nLiterals' 10 | 'a' 11 | z { 'abcdefghijklmnopqrstuvwxyz' 12 | 100 R z 13 | 4 4 R z 14 | tab { Lav[10] 15 | z[5] { tab 16 | z 17 | 18 | 19 | '\nVectors' 20 | I 50 21 | % I 10 22 | 23 | '\nArrays' 24 | 3 3 R I9 25 | 3 3 3 R I 3*3 26 | 27 | '\nPage Width' 28 | Lpw 29 | Lpw { 50 30 | I40 31 | Lpw { 72 32 | 33 | '\nPrint Precision' 34 | Lpp 35 | Lpp { 4 36 | % I 40 37 | 38 | '\nWARNING: setting Lpp over 15 may show up differences' 39 | ' between FPUs of different machines' 40 | Lpp { 15 41 | % I 10 42 | 43 | Lpp { 10 44 | Lpw { 72 45 | 46 | '\nE format' 47 | 1e`7 1e`23 1e`123 48 | 1.1e`7 1.1e`23 1.1e`123 49 | 50 | '\nThree digit exponent' 51 | a { 1e99 52 | b { 1e`99 53 | a 54 | a X 10 55 | a X a X a 56 | b 57 | b % 10 58 | b X b X b 59 | 60 | '\nCascade carry forward' 61 | 0.99999999999999999 62 | 23.9999999999999999 63 | `2.99999999999999999 64 | 65 | '\nQuad Output' 66 | L { 3 4 R I 12 67 | 68 | '\nSemicolon Output' 69 | I 10 ; 300+I 12 ; ' asdf' 70 | 71 | '\nMixing E format with rational format' 72 | Lpp { 9 73 | a { (0 1 2 3 4) J.% I 4 74 | a 75 | 10000 X a 76 | 1e9 X a 77 | `1e9 X a 78 | a % 10000 79 | 80 | '\nPushing both ends' 81 | b { 4 1 R `1.234e`56 1.2 0 1e9 82 | b 83 | b X 1000 84 | b % 1000 85 | b, b, b 86 | 87 | '\nColumn Formatting' 88 | m { 0.78901 X (10*I6) J.X 1 1e`10 1e`6 0.01 .1 89 | m 90 | Lpp { 4 91 | m 92 | 93 | -------------------------------------------------------------------------------- /qa/quad_fx.inp: -------------------------------------------------------------------------------- 1 | C@J Create a 2xN string array, 2 | C@J and then use Lfx to turn it into 3 | C@J a function. 4 | 5 | fn { 1 64 R 64 Y 'G z { sq n' 6 | fn { fn,[1] 1 64 R 64 Y 'z { n*2' 7 | 8 | fn 9 | 10 | Lfx fn 11 | 12 | )fns 13 | 14 | sq 4 15 | -------------------------------------------------------------------------------- /qa/quad_fx.ref: -------------------------------------------------------------------------------- 1 | G z { sq n 2 | z { n*2 3 | 4 | sq 5 | 16 6 | 7 | -------------------------------------------------------------------------------- /qa/quad_vars.ref: -------------------------------------------------------------------------------- 1 | Quad Input 2 | 4 3 | 5 4 | 5 | Quad Output 6 | 0.8 7 | 1024 8 | 1026 9 | 10 | Quote Quad Input 11 | quad_input_string1 12 | 13 | Quote quad Output 14 | quad_input_string2 15 | Limit Error: quote quad prompt not empty. 16 | quad_input_string5 17 | quad_input_string6 18 | Limit Error: assign value too long. 19 | quad_input_string7 20 | 21 | Quote quad Output Errors 22 | Domain Error: assign value not character. 23 | Rank Error: rank of assign value too large. 24 | 25 | Print Precision 26 | 9 27 | 0.333333333 28 | 0.333333333333333 29 | 30 | Comparision Tolerance 31 | 1e`13 32 | 33 | Atomic Vector 34 | !"#$%&'()*+,-./0123456789:;<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\]^_`abcdefg 35 | hijklmnopqrstuvwxyz{|}~ 36 | 37 | Index Origin 38 | 1 39 | 1 2 3 40 | 0 1 2 41 | 42 | Page Width 43 | 72 44 | 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 26 27 45 | 28 29 30 46 | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 47 | 20 21 22 23 24 25 26 27 28 29 30 48 | 50 49 | 50 | Time Stamp 51 | 7 52 | -------------------------------------------------------------------------------- /qa/quad_vars.sh: -------------------------------------------------------------------------------- 1 | #! ../source/aplette 2 | 3 | 'Quad Input' 4 | a { L 5 | a 6 | b { L 7 | b 8 | 9 | '\nQuad Output' 10 | L { a % b 11 | c { 2 + L { 4*5 12 | c 13 | 14 | '\nQuote Quad Input' 15 | a { '@L 16 | a 17 | 18 | '\nQuote quad Output' 19 | '@L { 'give me a number: ' 20 | a { '@L 21 | a 22 | 23 | J@C broken test 24 | J@C b { '@L { 'another please: ' 25 | J@C quad_input_string3 26 | J@C a { '@L 27 | J@C quad_input_string4 28 | J@C b 29 | 30 | '@L { 'abc ' 31 | '@L { 'def ' 32 | a { '@L 33 | a 34 | 35 | '@L { '123456789012345678901234567890123456789 ' 36 | a { '@L 37 | a 38 | 39 | '@L { '1234567890123456789012345678901234567890 ' 40 | a { '@L 41 | a 42 | 43 | '\nQuote quad Output Errors' 44 | '@L { 12 45 | '@L { 3 3 R 'abcdefghi' 46 | 47 | '\nPrint Precision' 48 | Lpp 49 | a { L { 1 % 3 50 | Lpp { 15 51 | a 52 | Lpp { 9 53 | 54 | '\nComparision Tolerance' 55 | Lct 56 | 57 | '\nAtomic Vector' 58 | 32 U 127 Y Lav 59 | 60 | '\nIndex Origin' 61 | Lio 62 | I 3 63 | Lio { 0 64 | I 3 65 | Lio { 1 66 | 67 | '\nPage Width' 68 | Lpw 69 | I 30 70 | Lpw { 50 71 | I 30 72 | Lpw 73 | Lpw { 72 74 | 75 | '\nTime Stamp' 76 | R Lts 77 | -------------------------------------------------------------------------------- /qa/quad_vars.stdin: -------------------------------------------------------------------------------- 1 | 4 2 | 5 3 | quad_input_string1 4 | quad_input_string2 5 | quad_input_string5 6 | quad_input_string6 7 | quad_input_string7 8 | -------------------------------------------------------------------------------- /qa/scalar_dyadic.inp: -------------------------------------------------------------------------------- 1 | 'Scalar Dyadic Functions' 2 | Lpp { 6 3 | L { a { `1e7 `200 `1.5 `1 0 1, (1 % 3), .5 7 2000 4 | L { b { (`3+ I 4), 2 % 3 5 | 6 | 'Plus' 7 | b J.+ b 8 | 9 | 'Minus' 10 | b J.- b 11 | 12 | 'Times' 13 | b J.X b 14 | 15 | 'divide' 16 | 0 1 2 3 4 J.% 1 2 3 4 17 | 18 | 'Maximum' 19 | b J.S b 20 | 21 | 'Minimum' 22 | b J.D b 23 | 24 | 'Power' 25 | Lpp { 12 26 | 2 * 32 27 | 4 * 0.5 28 | Lpp { 6 29 | 30 | 'Logarithm' 31 | 10 2 10 0.1 *@O 2 65536 1e15 1e15 32 | 33 | 'Residue' 34 | Lct { 1e`10 35 | 7 `7 J.| 31 28 `30 36 | 0.2 | 1.4 1.5 1.6 37 | 1 | 1e30 1e`30 `1e`30 .99999999999 38 | Lct { 0 39 | Lpp { 16 40 | 1 | 1e30 1e`30 `1e`30 .99999999999 41 | Lct { 1e`10 42 | Lpp { 9 43 | 44 | 'Binomial' 45 | 0 1 2 3 4 J.! 0 1 2 3 4 46 | 47 | 'Circular Functions - also see trig tests' 48 | 2 O `1 O .6 49 | 2 O 0 50 | 3 O O %4 51 | 6 O 0 52 | 53 | 'And' 54 | 0 1 J.^ 0 1 55 | 'LCM is not implemented' 56 | 57 | 'Or' 58 | 0 1 J.V 0 1 59 | 'GCD is not implemented' 60 | 61 | 'Nand' 62 | 0 1 J. ^@~ 0 1 63 | 64 | 'Nor' 65 | 0 1 J. V@~ 0 1 66 | 67 | 'Equal' 68 | 1 2 3 J.= 1 2 3 69 | Lct { 1e`13 70 | 4 = 4 + 5e`13 2e`13 `2e`13 `5e`13 71 | 0 = `1e`20 1e`20 0 72 | 3 = 'A3' 73 | 'A' = I 128 74 | (I 128) = 'a' 75 | 76 | 'Less Than' 77 | 1 2 3 J.< 1 2 3 78 | 0 1 J.< 0 1 79 | 80 | 'Less than or equal to' 81 | 1 2 3 J. <@= 1 2 3 82 | 0 1 J. <@= 0 1 83 | 84 | 'Not equal' 85 | 1 2 3 J. /@= 1 2 3 86 | 0 1 J. /@= 0 1 87 | 88 | 'Greater than or equal to' 89 | 1 2 3 J. =@> 1 2 3 90 | 0 1 J. =@> 0 1 91 | 92 | 'Greater than' 93 | 1 2 3 J.> 1 2 3 94 | 0 1 J.> 0 1 95 | 96 | 97 | -------------------------------------------------------------------------------- /qa/scalar_monadic.inp: -------------------------------------------------------------------------------- 1 | 'Monadic Scalar Functions' 2 | Lpp { 6 3 | L { a { `1e7 `200 `1.5 `1 0 1, (1 % 3), .5 7 2000 4 | 5 | 'Conjugate - not implemented' 6 | 7 | 'Negative' 8 | -a 9 | 10 | 'Direction' 11 | Xa 12 | 13 | 'Reciprocal' 14 | % (a /@= 0)/a 15 | % `.25 .5 1 2 `4 16 | % 0 17 | 18 | 'Floor' 19 | Lct { 1e`10 20 | D 0.999999999 21 | D 0.9999999999 22 | D `3.1416 3.1416 .99999999999 5e20 `0.5e`10 23 | 24 | 'Ceiling' 25 | Lct { 1e`10 26 | S 5.000000001 27 | S 5.0000000001 28 | S `3.1416 3.1416 5.00000000001 29 | 30 | 'Exponential' 31 | * `1e50 `2 `1 0 1 2 32 | * .693147 33 | 34 | 'Natural Logarithm' 35 | *@O 2.71828459045 2 1 1e`50 1e50 36 | *@O * 1 37 | 38 | 'Magnitude' 39 | | 1 `0.5 0.33 `0.25 0 1e`20 40 | 41 | 'Factorial' 42 | ! 0,I9 43 | ! `.5 44 | 5 1 R ! - 1.502 1.503 1.504 1.505 1.506 45 | 46 | 'PI times (see also trig tests)' 47 | O 1 10 100 48 | 49 | 'Not' 50 | ~ 0 1 1e`11 .999999999999 51 | -------------------------------------------------------------------------------- /qa/scalar_monadic.ref: -------------------------------------------------------------------------------- 1 | Monadic Scalar Functions 2 | `1e7 `200 `1.5 `1 0 1 0.333333 0.5 7 2000 3 | Conjugate - not implemented 4 | Negative 5 | 1e7 200 1.5 1 `0 `1 `0.333333 `0.5 `7 `2000 6 | Direction 7 | `1 `1 `1 `1 0 1 1 1 1 1 8 | Reciprocal 9 | `1e`7 `0.005 `0.666667 `1 1 3 2 0.142857 0.0005 10 | `4 2 1 0.5 `0.25 11 | Domain Error: reciprocal of zero attempted. 12 | Floor 13 | 0 14 | 1 15 | `4 3 1 5e20 0 16 | Ceiling 17 | 6 18 | 5 19 | `3 4 5 20 | Exponential 21 | 0 0.135335 0.367879 1 2.71828 7.38906 22 | 2 23 | Natural Logarithm 24 | 1 0.693147 0 `115.129 115.129 25 | 1 26 | Magnitude 27 | 1 0.5 0.33 0.25 0 1e`20 28 | Factorial 29 | 1 1 2 6 24 120 720 5040 40320 362880 30 | 1.77245 31 | `3.54471 32 | `3.54466 33 | `3.54464 34 | `3.54466 35 | `3.5447 36 | PI times (see also trig tests) 37 | 3.14159 31.4159 314.159 38 | Not 39 | 1 0 0 0 40 | 41 | -------------------------------------------------------------------------------- /qa/struct_dyadic.inp: -------------------------------------------------------------------------------- 1 | 'Dyadic Structural Primitives' 2 | 3 | '\nReshape' 4 | L { n213 { 2 1 3 R I 6 5 | 2 4 R n213 6 | 7 | R 0 R 'ABCD' 8 | 9 | b { 1e2 1e2 1e2 0 1e2 1e2 1e2 R 42 10 | R b 11 | 12 | '\n Reshape Domain Error' 13 | '\n' R n213 14 | 15 | '\nJoin' 16 | L { n233 { 2 3 3 R I 18 17 | L { n23 { 2 3 R I 6 18 | n233,n23 19 | n233,[3]n23 20 | n233,[2]n23 21 | n233,[1]n23 22 | 23 | L { n33 { 3 3 R I 9 24 | n233,[1]n33 25 | 26 | Lio { 0 27 | n233,[3] n23 28 | n233,[2] n23 29 | n233,[1] n23 30 | n233,[0] n33 31 | -------------------------------------------------------------------------------- /qa/struct_dyadic.ref: -------------------------------------------------------------------------------- 1 | Dyadic Structural Primitives 2 | 3 | Reshape 4 | 1 2 3 5 | 6 | 4 5 6 7 | 1 2 3 4 8 | 5 6 1 2 9 | 0 10 | 100 100 100 0 100 100 100 11 | 12 | Reshape Domain Error 13 | Domain Error. 14 | 15 | Join 16 | 1 2 3 17 | 4 5 6 18 | 7 8 9 19 | 20 | 10 11 12 21 | 13 14 15 22 | 16 17 18 23 | 1 2 3 24 | 4 5 6 25 | 1 2 3 1 26 | 4 5 6 2 27 | 7 8 9 3 28 | 29 | 10 11 12 4 30 | 13 14 15 5 31 | 16 17 18 6 32 | 1 2 3 1 33 | 4 5 6 2 34 | 7 8 9 3 35 | 36 | 10 11 12 4 37 | 13 14 15 5 38 | 16 17 18 6 39 | 1 2 3 40 | 4 5 6 41 | 7 8 9 42 | 1 2 3 43 | 44 | 10 11 12 45 | 13 14 15 46 | 16 17 18 47 | 4 5 6 48 | Length Error: sizes do not match. 49 | 1 2 3 50 | 4 5 6 51 | 7 8 9 52 | 1 2 3 53 | 4 5 6 54 | 7 8 9 55 | 56 | 10 11 12 57 | 13 14 15 58 | 16 17 18 59 | 60 | 1 2 3 61 | 4 5 6 62 | 7 8 9 63 | Index Error. 64 | 1 2 3 1 65 | 4 5 6 2 66 | 7 8 9 3 67 | 68 | 10 11 12 4 69 | 13 14 15 5 70 | 16 17 18 6 71 | 1 2 3 72 | 4 5 6 73 | 7 8 9 74 | 1 2 3 75 | 76 | 10 11 12 77 | 13 14 15 78 | 16 17 18 79 | 4 5 6 80 | 1 2 3 81 | 4 5 6 82 | 7 8 9 83 | 84 | 10 11 12 85 | 13 14 15 86 | 16 17 18 87 | 88 | 1 2 3 89 | 4 5 6 90 | 7 8 9 91 | 92 | -------------------------------------------------------------------------------- /qa/struct_monadic.inp: -------------------------------------------------------------------------------- 1 | 'Monadic Structural Primitives' 2 | 3 | 0 0 0 \ I 0 4 | 1 0 1 0 1 \ 4 3 R I 12 5 | 0 0 0 \ 4 0 R 0 6 | 7 | '\nRavel' 8 | L { n22 { 2 2 R I 4 9 | L { n222 { 2 2 2 R I 8 10 | L { n2221 { 2 2 2 1 R I 8 11 | 12 | , n22 13 | , n222 14 | , n2221 15 | 16 | '\nShape' 17 | L { n { 1 18 | L { n3 { I 3 19 | L { n34 { 3 4 R I 12 20 | 21 | R n 22 | R, n 23 | R R n 24 | R n3 25 | R R n3 26 | R n34 27 | 28 | '\nIndex Generator' 29 | Lio { 0 30 | I 4 31 | Lio { 1 32 | I 4 33 | 34 | '\nTable - not implemented' 35 | '\nDepth - not implemented' 36 | '\nEnlist - not implemented' 37 | -------------------------------------------------------------------------------- /qa/struct_monadic.ref: -------------------------------------------------------------------------------- 1 | Monadic Structural Primitives 2 | 0 0 0 3 | 1 0 2 0 3 4 | 4 0 5 0 6 5 | 7 0 8 0 9 6 | 10 0 11 0 12 7 | 0 0 0 8 | 0 0 0 9 | 0 0 0 10 | 0 0 0 11 | 12 | Ravel 13 | 1 2 14 | 3 4 15 | 1 2 16 | 3 4 17 | 18 | 5 6 19 | 7 8 20 | 1 21 | 2 22 | 23 | 3 24 | 4 25 | 26 | 27 | 5 28 | 6 29 | 30 | 7 31 | 8 32 | 1 2 3 4 33 | 1 2 3 4 5 6 7 8 34 | 1 2 3 4 5 6 7 8 35 | 36 | Shape 37 | 1 38 | 1 2 3 39 | 1 2 3 4 40 | 5 6 7 8 41 | 9 10 11 12 42 | 43 | 1 44 | 0 45 | 3 46 | 1 47 | 3 4 48 | 49 | Index Generator 50 | 0 1 2 3 51 | 1 2 3 4 52 | 53 | Table - not implemented 54 | 55 | Depth - not implemented 56 | 57 | Enlist - not implemented 58 | 59 | -------------------------------------------------------------------------------- /qa/trig.inp: -------------------------------------------------------------------------------- 1 | 'Circular Functions' 2 | 3 | a { `5 `2 `1.75 `1.5 `1 `.5 4 | b { 0, (1 % 3), .5, (2 % 3), .75 .9 1 1.1 1.5 1.75 5 | c { 2 3 10 6 | multiples { (a, b, c) J.X I 1 7 | radians { O multiples 8 | 9 | C@J output is restricted to 4 decimal places 10 | C@J as exposing too much accuracy can lead to false errors 11 | C@J due to differences between FPUs on different machines 12 | Lpp { 4 13 | 14 | 'Sine' 15 | 6 2 9 4 8 4 8 4 J@N multiples,radians,(1 O radians),`1 O 1 O radians 16 | 17 | 'Cosine' 18 | 6 2 9 4 8 4 8 4 J@N multiples,radians,(2 O radians),`2 O 2 O radians 19 | 20 | 'Hyperbolic Sine' 21 | 6 2 7 2 12 `4 6 2 J@N multiples,radians,(5 O radians),`5 O 5 O radians 22 | 23 | 'Hyperbolic Cosine' 24 | 6 2 7 2 12 `4 6 2 J@N multiples,radians,(6 O radians),`6 O 6 O radians 25 | 26 | A { `5 `2 `1.75 `1 C@J For tan() which is infinity at pi%2 27 | multiples { (a, b, c) J.X I 1 28 | radians { O multiples 29 | 30 | 'Tangent' 31 | 6 2 9 4 8 4 8 4 J@N multiples, radians, (3 O radians), `3 O 3 O radians 32 | 33 | 'Hyperbolic Tangent' 34 | 6 2 7 2 8 4 6 2 J@N multiples, radians, (7 O radians), `7 O 7 O radians 35 | C@J In the above, some of the 1.0000's are actually 0.999999 36 | 37 | 'Checking for infinity from tan()' 38 | O 1 39 | O 1.5 40 | 3 O O 1.5 41 | 42 | -------------------------------------------------------------------------------- /qa/ulam.ws: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/gregfjohnson/aplette/cc5009c197b182cbe3d3cc32a35594ced0bf9729/qa/ulam.ws -------------------------------------------------------------------------------- /qa/userfunc_nilret1.inp: -------------------------------------------------------------------------------- 1 | 'Test of )read. function with no return value.' 2 | 3 | Lchdir 'clean_dir' 4 | 5 | )read nilret1 6 | nilret1 7 | )vars 8 | )fns 9 | -------------------------------------------------------------------------------- /qa/userfunc_nilret1.ref: -------------------------------------------------------------------------------- 1 | Test of )read. function with no return value. 2 | 0 3 | 1 4 | a 5 | nilret1 6 | 7 | -------------------------------------------------------------------------------- /qa/userfunc_onearg1.inp: -------------------------------------------------------------------------------- 1 | 'Test of )read. monadic function with a return value.' 2 | 3 | Lchdir 'clean_dir' 4 | 5 | )read onearg 6 | onearg 5 7 | )vars 8 | )fns 9 | -------------------------------------------------------------------------------- /qa/userfunc_onearg1.ref: -------------------------------------------------------------------------------- 1 | Test of )read. monadic function with a return value. 2 | 0 3 | 3125 4 | 5 | onearg 6 | 7 | -------------------------------------------------------------------------------- /qa/userfunc_shadow2.inp: -------------------------------------------------------------------------------- 1 | Gz { fac n 2 | }(n > 1) / big 3 | z { 1 4 | }0 5 | big: z { n X fac n-1 6 | G 7 | 8 | fac 4 9 | 10 | big { 47 11 | fac 4 12 | big 13 | 14 | n { 19 15 | fac 4 16 | n 17 | -------------------------------------------------------------------------------- /qa/userfunc_shadow2.ref: -------------------------------------------------------------------------------- 1 | 24 2 | 24 3 | 47 4 | 24 5 | 19 6 | 7 | -------------------------------------------------------------------------------- /qa/userfunc_shadow_arg.inp: -------------------------------------------------------------------------------- 1 | 'Test of global variable shadowed by function arg.' 2 | 3 | Lchdir 'clean_dir' 4 | 5 | )read pfoo 6 | u { 'u oops' 7 | v { 'v oops' 8 | 4 pfoo 5 9 | -------------------------------------------------------------------------------- /qa/userfunc_shadow_arg.ref: -------------------------------------------------------------------------------- 1 | Test of global variable shadowed by function arg. 2 | 0 3 | 4 4 | 5 5 | xx 6 | 7 | -------------------------------------------------------------------------------- /qa/userfunc_shadow_globals.inp: -------------------------------------------------------------------------------- 1 | Gz { a sq b; c; noshadow 2 | l1: noshadow { c { a*b 3 | l2: z { a O@* noshadow 4 | G 5 | 6 | z { 'shadowed output local variable' 7 | a { 'shadowed' 8 | b { 'shadowed right argument' 9 | c { 'shadowed local variable' 10 | l1 { 'shadowed label' 11 | l2 { 'another shadowed label' 12 | 13 | q { 10 sq 12 14 | 15 | 'q:' 16 | q 17 | 18 | 'z:' 19 | z 20 | 21 | 'a:' 22 | a 23 | 24 | 'b:' 25 | b 26 | 27 | 'c:' 28 | c 29 | 30 | 'noshadow:' 31 | noshadow 32 | 33 | 'l1:' 34 | l1 35 | 36 | 'l2:' 37 | l2 38 | -------------------------------------------------------------------------------- /qa/userfunc_shadow_globals.ref: -------------------------------------------------------------------------------- 1 | q: 2 | 12 3 | z: 4 | shadowed output local variable 5 | a: 6 | shadowed 7 | b: 8 | shadowed right argument 9 | c: 10 | shadowed local variable 11 | noshadow: 12 | Value Error: undefined variable. 13 | l1: 14 | shadowed label 15 | l2: 16 | another shadowed label 17 | 18 | -------------------------------------------------------------------------------- /qa/userfunc_shadow_undefined.inp: -------------------------------------------------------------------------------- 1 | Gz { a sq b; c; d 2 | d { c { a*b 3 | z { a O@* d 4 | G 5 | 6 | z { 'shadowed output local variable' 7 | a { 'shadowed left argument' 8 | c { 'shadowed local variable' 9 | 10 | q { 10 sq 12 11 | 12 | 'q:' 13 | q 14 | 15 | 'z:' 16 | z 17 | 18 | 'a:' 19 | a 20 | 21 | 'b:' 22 | b 23 | 24 | 'c:' 25 | c 26 | -------------------------------------------------------------------------------- /qa/userfunc_shadow_undefined.ref: -------------------------------------------------------------------------------- 1 | q: 2 | 12 3 | z: 4 | shadowed output local variable 5 | a: 6 | shadowed left argument 7 | b: 8 | Value Error: undefined variable. 9 | c: 10 | shadowed local variable 11 | 12 | -------------------------------------------------------------------------------- /qa/userfunc_stdin.inp: -------------------------------------------------------------------------------- 1 | Gz { foo n 2 | z { (In) J.* I4 3 | G 4 | 5 | foo 10 6 | -------------------------------------------------------------------------------- /qa/userfunc_stdin.ref: -------------------------------------------------------------------------------- 1 | 1 1 1 1 2 | 2 4 8 16 3 | 3 9 27 81 4 | 4 16 64 256 5 | 5 25 125 625 6 | 6 36 216 1296 7 | 7 49 343 2401 8 | 8 64 512 4096 9 | 9 81 729 6561 10 | 10 100 1000 10000 11 | 12 | -------------------------------------------------------------------------------- /qa/userfunc_t1.inp: -------------------------------------------------------------------------------- 1 | y { `1 + I40 2 | mat { 40 1 R I40 3 | mat { mat, 1 4 | 5 | Gz { y r2 mat 6 | beta { y L@% mat 7 | yhat { mat +.X beta 8 | ss_res { +/(y - yhat)*2 9 | mean { (+/y) % Ry 10 | ss_tot { +/(y-mean)*2 11 | z { 1 - ss_res % ss_tot 12 | G 13 | 14 | y r2 mat 15 | y r2 mat 16 | 17 | y[1] { 10 18 | y r2 mat 19 | -------------------------------------------------------------------------------- /qa/userfunc_t1.ref: -------------------------------------------------------------------------------- 1 | 1 2 | 1 3 | 0.982061369 4 | 5 | -------------------------------------------------------------------------------- /qa/userfunc_twoargs1.inp: -------------------------------------------------------------------------------- 1 | 'Test of )read. dyadic function with a return value.' 2 | 3 | Lchdir 'clean_dir' 4 | 5 | )read twoargs 6 | 2 twoargs 5 7 | )vars 8 | )fns 9 | -------------------------------------------------------------------------------- /qa/userfunc_twoargs1.ref: -------------------------------------------------------------------------------- 1 | Test of )read. dyadic function with a return value. 2 | 0 3 | 32 4 | 5 | twoargs 6 | 7 | -------------------------------------------------------------------------------- /qa/userfunc_withret1.inp: -------------------------------------------------------------------------------- 1 | 'Test of )read. niladic function with a return value.' 2 | 3 | Lchdir 'clean_dir' 4 | 5 | )read withret1 6 | withret1 7 | )vars 8 | )fns 9 | -------------------------------------------------------------------------------- /qa/userfunc_withret1.ref: -------------------------------------------------------------------------------- 1 | Test of )read. niladic function with a return value. 2 | 0 3 | 0.1 4 | 5 | withret1 6 | 7 | -------------------------------------------------------------------------------- /source/Docs/global_replace: -------------------------------------------------------------------------------- 1 | #! /bin/sh 2 | 3 | find_string='contemp' 4 | replace_string='thisContext' 5 | 6 | for file in */*.c ; do 7 | if (grep $find_string $file > /dev/null ) then 8 | echo $file 9 | cat $file | sed "s/$find_string/$replace_string/g" > temp 10 | mv temp $file 11 | fi 12 | done 13 | -------------------------------------------------------------------------------- /source/data/Makefile: -------------------------------------------------------------------------------- 1 | # Makefile for data 2 | 3 | include ../include/makefile.common 4 | CFLAGS += -I../include 5 | 6 | OBJECTS = access.o dupdat.o getdata.o putdat.o top.o \ 7 | bidx.o copy.o erase.o newdat.o s2vect.o \ 8 | colapse.o fetch.o nlook.o size.o pop.o \ 9 | data_iterator.o rbtree.o symtab.o 10 | 11 | all: Q.o 12 | 13 | Q.o: $(OBJECTS) 14 | $(LD) -r -o Q.o $(OBJECTS) 15 | 16 | $(OBJECTS): ../include/apl.h 17 | 18 | # Things that depend on characters 19 | fetch.o : ../include/char.h ../include/opt_codes.h 20 | 21 | .c.o: 22 | $(CC) $(CFLAGS) -c $< 23 | 24 | unit_test: data_iterator_unit_test 25 | 26 | data_iterator_unit_test: data_iterator.c 27 | $(CC) $(CFLAGS) -DUNIT_TEST -o data_iterator_unit_test data_iterator.c 28 | 29 | clean: 30 | rm -f $(OBJECTS) core data_iterator_unit_test 31 | 32 | -------------------------------------------------------------------------------- /source/data/access.c: -------------------------------------------------------------------------------- 1 | /* Copyright U S WEST Advanced Technologies, Inc. 2 | * You may use, copy, modify and sublicense this Software 3 | * subject to the conditions expressed in the file "License". 4 | */ 5 | #include "apl.h" 6 | 7 | int access() { 8 | int i, n; 9 | 10 | n = 0; 11 | for (i = 0; i < idx.rank; i++) 12 | n += idx.idx[i] * idx.del[i]; 13 | return (n); 14 | } 15 | -------------------------------------------------------------------------------- /source/data/bidx.c: -------------------------------------------------------------------------------- 1 | /* Copyright U S WEST Advanced Technologies, Inc. 2 | * You may use, copy, modify and sublicense this Software 3 | * subject to the conditions expressed in the file "License". 4 | */ 5 | #include "apl.h" 6 | #include "data.h" 7 | 8 | void bidx(item_t* ip) 9 | { 10 | item_t* p; 11 | 12 | p = ip; 13 | idx.type = p->itemType; 14 | idx.rank = p->rank; 15 | copy(IN, (char*)p->dim, (char*)idx.dim, idx.rank); 16 | size(); 17 | } 18 | -------------------------------------------------------------------------------- /source/data/colapse.c: -------------------------------------------------------------------------------- 1 | /* Copyright U S WEST Advanced Technologies, Inc. 2 | * You may use, copy, modify and sublicense this Software 3 | * subject to the conditions expressed in the file "License". 4 | */ 5 | #include "apl.h" 6 | #include "utility.h" 7 | 8 | void colapse(int k) 9 | { 10 | int i; 11 | 12 | if (k < 0 || k >= idx.rank) 13 | error(ERR_index, "collapse"); 14 | idx.dimk = idx.dim[k]; 15 | idx.delk = idx.del[k]; 16 | for (i = k; i < idx.rank; i++) { 17 | idx.del[i] = idx.del[i + 1]; 18 | idx.dim[i] = idx.dim[i + 1]; 19 | } 20 | if (idx.dimk) 21 | idx.size /= idx.dimk; 22 | idx.rank--; 23 | } 24 | -------------------------------------------------------------------------------- /source/data/copy.c: -------------------------------------------------------------------------------- 1 | /* Copyright U S WEST Advanced Technologies, Inc. 2 | * You may use, copy, modify and sublicense this Software 3 | * subject to the conditions expressed in the file "License". 4 | */ 5 | #include "apl.h" 6 | 7 | int copy(int type, char* from, char* to, int size) 8 | { 9 | int i; 10 | char *a, *b; 11 | int s; 12 | 13 | if (size == 0) 14 | return (0); 15 | 16 | i = size; 17 | a = from; 18 | b = to; 19 | if (type == DA) 20 | i *= SDAT; 21 | if (type == IN) 22 | i *= SINT; 23 | if (type == PTR) 24 | i *= SPTR; 25 | s = i; 26 | do 27 | *b++ = *a++; 28 | while (--i); 29 | 30 | return (s); 31 | } 32 | -------------------------------------------------------------------------------- /source/data/dupdat.c: -------------------------------------------------------------------------------- 1 | /* Copyright U S WEST Advanced Technologies, Inc. 2 | * You may use, copy, modify and sublicense this Software 3 | * subject to the conditions expressed in the file "License". 4 | */ 5 | #include "apl.h" 6 | #include "data.h" 7 | 8 | item_t* dupdat(item_t* ap) { 9 | item_t *p1, *p2; 10 | int i; 11 | 12 | p1 = ap; 13 | p2 = newdat(p1->itemType, p1->rank, p1->size); 14 | for (i = 0; i < p1->rank; i++) 15 | p2->dim[i] = p1->dim[i]; 16 | copy(p1->itemType, (char*)p1->datap, (char*)p2->datap, p1->size); 17 | return (p2); 18 | } 19 | -------------------------------------------------------------------------------- /source/data/erase.c: -------------------------------------------------------------------------------- 1 | /* Copyright U S WEST Advanced Technologies, Inc. 2 | * You may use, copy, modify and sublicense this Software 3 | * subject to the conditions expressed in the file "License". 4 | */ 5 | #include "apl.h" 6 | #include "memory.h" 7 | #include "data.h" 8 | #include "utility.h" 9 | 10 | void erase(SymTabEntry* np) 11 | { 12 | int i; 13 | 14 | if (np) { 15 | switch (np->entryUse) { 16 | case CH: 17 | case DA: 18 | case EL: 19 | case QV: 20 | case NIL: 21 | aplfree(np->itemp->datap); 22 | aplfree(np->itemp); 23 | np->itemp = 0; 24 | break; 25 | 26 | case NF: 27 | case MF: 28 | case DF: 29 | // free the p-code that np points to. 30 | for (i = 0; i < np->functionLineLength; ++i) { 31 | aplfree(np->functionLines[i]); 32 | } 33 | if (np->functionLines != NULL) { 34 | aplfree(np->functionLines); 35 | } 36 | 37 | np->functionLines = NULL; 38 | np->functionLineCount = 0; 39 | np->functionLineLength = 0; 40 | break; 41 | 42 | default: 43 | break; 44 | } 45 | np->entryUse = UNKNOWN; 46 | symtabDelete(np); 47 | } 48 | } 49 | -------------------------------------------------------------------------------- /source/data/getdata.c: -------------------------------------------------------------------------------- 1 | /* Copyright U S WEST Advanced Technologies, Inc. 2 | * You may use, copy, modify and sublicense this Software 3 | * subject to the conditions expressed in the file "License". 4 | */ 5 | #include "apl.h" 6 | #include "utility.h" 7 | #include "data.h" 8 | 9 | data getdat(item_t* ip) { 10 | item_t* p; 11 | int i; 12 | data d; 13 | 14 | /* Get the data value stored at index p->index. If the 15 | * index is out of range it will be wrapped around. If 16 | * the data item is null, a zero or blank will be returned. 17 | */ 18 | 19 | p = ip; 20 | i = p->index; 21 | while (i >= p->size) { 22 | if (p->size == 0) 23 | return ((p->itemType == DA) ? zero : (data)' ') /* let the caller beware */; 24 | i -= p->size; 25 | } 26 | if (p->itemType == DA) { 27 | d = p->datap[i]; 28 | } 29 | else if (p->itemType == CH) { 30 | d = ((struct chrstrct*)p->datap)->c[i]; 31 | } 32 | else 33 | error(ERR_botch, "getdat"); 34 | i++; 35 | p->index = i; 36 | return (d); 37 | } 38 | -------------------------------------------------------------------------------- /source/data/nlook.c: -------------------------------------------------------------------------------- 1 | /* Copyright U S WEST Advanced Technologies, Inc. 2 | * You may use, copy, modify and sublicense this Software 3 | * subject to the conditions expressed in the file "License". 4 | */ 5 | #include "apl.h" 6 | #include "data.h" 7 | 8 | SymTabEntry* nlook(char* name) 9 | { 10 | return symtabFind(name); 11 | } 12 | -------------------------------------------------------------------------------- /source/data/pop.c: -------------------------------------------------------------------------------- 1 | /* Copyright U S WEST Advanced Technologies, Inc. 2 | * You may use, copy, modify and sublicense this Software 3 | * subject to the conditions expressed in the file "License". 4 | */ 5 | #include 6 | #include "apl.h" 7 | #include "utility.h" 8 | #include "memory.h" 9 | #include "debug.h" 10 | 11 | void pop() { 12 | item_t* p; 13 | 14 | if (stack_trace) { 15 | printf("pop expr_stack..\n"); 16 | } 17 | 18 | if (expr_stack_ptr <= expr_stack) { 19 | error(ERR_botch, "pop - expr_stack underflow"); 20 | } 21 | p = expr_stack_ptr[-1]; 22 | if (p) { 23 | switch (p->itemType) { 24 | default: 25 | printf("[bad type: %s]\n", ItemType_str(p->itemType)); 26 | error(ERR_botch, "pop - unrecognised type"); 27 | break; 28 | 29 | case LBL: 30 | ((SymTabEntry*)p)->entryUse = UNKNOWN; /* delete label */ 31 | 32 | case UNKNOWN: 33 | case LV: 34 | break; 35 | 36 | case DA: 37 | case CH: 38 | aplfree(p->datap); 39 | aplfree(p); 40 | break; 41 | 42 | // case QQ: 43 | // case QD: 44 | case EL: 45 | case NIL: 46 | case QX: 47 | case QV: 48 | aplfree(p); 49 | } 50 | } 51 | expr_stack_ptr--; 52 | } 53 | -------------------------------------------------------------------------------- /source/data/putdat.c: -------------------------------------------------------------------------------- 1 | /* Copyright U S WEST Advanced Technologies, Inc. 2 | * You may use, copy, modify and sublicense this Software 3 | * subject to the conditions expressed in the file "License". 4 | */ 5 | #include "apl.h" 6 | #include "utility.h" 7 | 8 | void putdat(item_t* ip, data d) 9 | { 10 | item_t* p; 11 | int i; 12 | 13 | p = ip; 14 | i = p->index; 15 | if (i >= p->size) 16 | error(ERR_botch, "putdat - index exceeds size"); 17 | if (p->itemType == DA) { 18 | p->datap[i] = d; 19 | } 20 | else if (p->itemType == CH) { 21 | ((struct chrstrct*)p->datap)->c[i] = d; 22 | } 23 | else 24 | error(ERR_botch, "putdat - unrecognised type"); 25 | i++; 26 | p->index = i; 27 | } 28 | -------------------------------------------------------------------------------- /source/data/s2vect.c: -------------------------------------------------------------------------------- 1 | /* Copyright U S WEST Advanced Technologies, Inc. 2 | * You may use, copy, modify and sublicense this Software 3 | * subject to the conditions expressed in the file "License". 4 | */ 5 | #include "apl.h" 6 | #include "data.h" 7 | 8 | item_t* 9 | s2vect(ap) item_t* ap; 10 | { 11 | item_t *p, *q; 12 | 13 | p = ap; 14 | q = newdat(p->itemType, 1, 1); 15 | q->datap = p->datap; 16 | q->dim[0] = 1; 17 | return (q); 18 | } 19 | -------------------------------------------------------------------------------- /source/data/size.c: -------------------------------------------------------------------------------- 1 | /* Copyright U S WEST Advanced Technologies, Inc. 2 | * You may use, copy, modify and sublicense this Software 3 | * subject to the conditions expressed in the file "License". 4 | */ 5 | #include "apl.h" 6 | 7 | int size() 8 | { 9 | int i, s; 10 | 11 | s = 1; 12 | for (i = idx.rank - 1; i >= 0; i--) { 13 | idx.del[i] = s; 14 | s *= idx.dim[i]; 15 | } 16 | idx.size = s; 17 | return (s); 18 | } 19 | -------------------------------------------------------------------------------- /source/data/top.c: -------------------------------------------------------------------------------- 1 | /* Copyright U S WEST Advanced Technologies, Inc. 2 | * You may use, copy, modify and sublicense this Software 3 | * subject to the conditions expressed in the file "License". 4 | */ 5 | #include "apl.h" 6 | #include "utility.h" 7 | #include "data.h" 8 | 9 | double top() 10 | { 11 | item_t* p; 12 | double d; 13 | 14 | p = fetch1(); 15 | if (p->itemType != DA) 16 | error(ERR_implicit, "topval - bad data type"); 17 | if (p->size != 1) 18 | error(ERR_implicit, "topval - size is not 1"); 19 | d = p->datap[0]; 20 | pop(); 21 | return d; 22 | } 23 | -------------------------------------------------------------------------------- /source/debug/Makefile: -------------------------------------------------------------------------------- 1 | # Makefile for debug 2 | 3 | include ../include/makefile.common 4 | CFLAGS += -I../include 5 | 6 | OBJECTS = code_dump.o stack_dump.o mem_dump.o vars_dump.o parsedump.o 7 | 8 | all: Q.o 9 | 10 | Q.o: $(OBJECTS) 11 | $(LD) -r -o Q.o $(OBJECTS) 12 | 13 | $(OBJECTS): ../include/apl.h 14 | 15 | # Things that depend on characters 16 | code_dump.o: ../include/char.h ../include/opt_codes.h 17 | 18 | mem_dump.o: ../include/memory.h 19 | 20 | .c.o: 21 | $(CC) $(CFLAGS) -c $< 22 | 23 | clean: 24 | rm -f $(OBJECTS) core 25 | 26 | -------------------------------------------------------------------------------- /source/debug/mem_dump.c: -------------------------------------------------------------------------------- 1 | /* openAPL, Copyright (C) Branko Bratkovic 1998 2 | * This file is free software and is covered by the GNU General 3 | * Public License. 4 | * 5 | * This program is distributed in the hope that it will be useful, 6 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 7 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. 8 | * 9 | * For more details see the GNU General Public License (GPL) in 10 | * the docs directory. 11 | */ 12 | 13 | #include 14 | #include "memory.h" 15 | #include "apl.h" 16 | 17 | void mem_dump() 18 | { 19 | struct memblock* item; 20 | printf("Dumping dynamic memory... \n"); 21 | printf("firstblock, points to %p \n", (void *) firstblock); 22 | 23 | if (firstblock == 0) { 24 | printf("no dynamic memory\n"); 25 | return; 26 | } 27 | for (item = firstblock; item; item = item->next) { 28 | printf("%p points to %d bytes at %p \n", 29 | (void *)item, item->nbytes, (void *)item->block); 30 | } 31 | } 32 | -------------------------------------------------------------------------------- /source/debug/parsedump.c: -------------------------------------------------------------------------------- 1 | /* parsedump.c, Copyright (C) 2016, Greg Johnson 2 | * Released under the terms of the GNU GPL v2.0. 3 | * 4 | * This program is distributed in the hope that it will be useful, 5 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 6 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 7 | * GNU General Public License for more details. 8 | */ 9 | #include 10 | #include "apl.h" 11 | 12 | void parseDump(char* line, int len) 13 | { 14 | int i; 15 | 16 | if (!code_trace) 17 | return; 18 | 19 | for (i = 0; i < len; ++i) { 20 | fprintf(stderr, "%02x ", 0xff & line[i]); 21 | } 22 | fprintf(stderr, "\n"); 23 | } 24 | -------------------------------------------------------------------------------- /source/debug/vars_dump.c: -------------------------------------------------------------------------------- 1 | /* openAPL, Copyright (C) Branko Bratkovic 1999 2 | * This file is free software and is covered by the GNU General 3 | * Public License. 4 | * 5 | * This program is distributed in the hope that it will be useful, 6 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 7 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. 8 | * 9 | * For more details see the GNU General Public License (GPL) in 10 | * the docs directory. 11 | */ 12 | 13 | #include 14 | #include "apl.h" 15 | #include "data.h" 16 | #include "debug.h" 17 | 18 | void vars_dump() 19 | { 20 | SymTabEntry* n; 21 | 22 | printf("=== symbol table start ===\n"); 23 | symtabIterateInit(); 24 | while ((n = symtabIterate()) != NULL) { 25 | printf("%p:", (void *) n); 26 | printf(" namep=%s", n->namep); 27 | printf(" itemp=%p", (void *)n->itemp); 28 | printf(" use=%s", ItemType_str(n->entryUse)); 29 | printf(" itemType=%s", ItemType_str(n->itemType)); 30 | printf("\n"); 31 | } 32 | printf("=== symbol table end ===\n\n"); 33 | } 34 | -------------------------------------------------------------------------------- /source/execute/Makefile: -------------------------------------------------------------------------------- 1 | # Makefile for execute 2 | 3 | include ../include/makefile.common 4 | CFLAGS += -I../include 5 | 6 | OBJECTS = ex_dscal.o ex_botch.o ex_cdyad.o ex_ddyad.o execute.o \ 7 | ex_mdyad.o 8 | 9 | all: Q.o 10 | 11 | Q.o: $(OBJECTS) 12 | $(LD) -r -o Q.o $(OBJECTS) 13 | 14 | $(OBJECTS): ../include/apl.h 15 | 16 | execute.o: ../include/opt_codes.h 17 | 18 | .c.o: 19 | $(CC) $(CFLAGS) -c $< 20 | 21 | clean: 22 | rm -f $(OBJECTS) core 23 | 24 | -------------------------------------------------------------------------------- /source/execute/ex_botch.c: -------------------------------------------------------------------------------- 1 | /* Copyright U S WEST Advanced Technologies, Inc. 2 | * You may use, copy, modify and sublicense this Software 3 | * subject to the conditions expressed in the file "License". 4 | */ 5 | #include "apl.h" 6 | #include "utility.h" 7 | 8 | void ex_botch() 9 | { 10 | error(ERR_botch, "implementation"); 11 | } 12 | -------------------------------------------------------------------------------- /source/execute/ex_dscal.c: -------------------------------------------------------------------------------- 1 | /* Copyright U S WEST Advanced Technologies, Inc. 2 | * You may use, copy, modify and sublicense this Software 3 | * subject to the conditions expressed in the file "License". 4 | */ 5 | #include "apl.h" 6 | #include "utility.h" 7 | #include "execute.h" 8 | 9 | /* execute dyadic scalar functions 10 | * this routine is called from execute() 11 | * 'm' indicates whether the function may or not operate with char 12 | * this routine makes a decision and passes control to 13 | * one of the specialist routines: 14 | * * ex_cdyad - character dyadic 15 | * * ex_ddyad - floating point dyadic (ie type d) 16 | * * ex_mdyad - mixed dyadic 17 | */ 18 | void ex_dscal(int m, data (*f)(), item_t* p1, item_t* p2) 19 | { 20 | if (p1->itemType != p2->itemType) { 21 | if (m == 2) { 22 | // true for operators "=" and not_equal. 23 | // only case where operand types can be different. 24 | ex_mdyad((data (*)()) f, p1, p2); 25 | 26 | } else { 27 | error(ERR_domain, "dscal - types do not match"); 28 | } 29 | 30 | } else if (p1->itemType == CH) { 31 | if (m) { 32 | ex_cdyad((data (*)()) f, p1, p2); 33 | 34 | } else { 35 | error(ERR, "dscal - type panic"); 36 | } 37 | 38 | } else { 39 | ex_ddyad((data (*)()) f, p1, p2); 40 | } 41 | } 42 | -------------------------------------------------------------------------------- /source/execute/ex_mdyad.c: -------------------------------------------------------------------------------- 1 | #include "apl.h" 2 | #include "data.h" 3 | #include "utility.h" 4 | 5 | /* this routine deals with dyadic scalar functions 6 | * with different argument types. only used for 7 | * functions "equal" and "not_equal". In the former 8 | * case, return all 0's, in the latter case return 9 | * all 1's. 10 | * (provided shapes are compatible.) 11 | */ 12 | 13 | /* function added by tyl */ 14 | void ex_mdyad(data (*f)(), item_t* argptr0, item_t* argptr1) { 15 | int i; 16 | item_t *use_dims; 17 | item_t *result; 18 | 19 | if (argptr0->rank == 0 || argptr0->size == 1) { 20 | use_dims = argptr1; 21 | 22 | } else if (argptr1->rank == 0 || argptr1->size == 1) { 23 | use_dims = argptr0; 24 | 25 | } else { 26 | if (argptr0->rank != argptr1->rank) 27 | error(ERR_rank, "mixdyad - arrays do not match"); 28 | 29 | for (i = 0; i < argptr0->rank; i++) { 30 | if (argptr0->dim[i] != argptr1->dim[i]) 31 | error(ERR_length, "mixdyad - arrays do not match"); 32 | } 33 | use_dims = argptr0; 34 | } 35 | 36 | result = newdat(DA, use_dims->rank, use_dims->size); 37 | 38 | for (i = 0; i < use_dims->rank; ++i) 39 | result->dim[i] = use_dims->dim[i]; 40 | 41 | // test case to see if "f" implements "equal" or "not_equal". 42 | data value = (*f)((data) 0., (data) 1.); 43 | 44 | // fill the result array with the result. 45 | // 46 | for (int i = 0; i < use_dims->size; ++i) 47 | result->datap[i] = value; 48 | 49 | pop(); 50 | pop(); 51 | *expr_stack_ptr++ = result; 52 | } 53 | -------------------------------------------------------------------------------- /source/format/Makefile: -------------------------------------------------------------------------------- 1 | # Makefile for format conversions (ie downtackjot) 2 | 3 | include ../include/makefile.common 4 | CFLAGS += -I../include 5 | 6 | OBJECTS = ex_mfmt.o fp_mfmt.o fp_digits.o fp2char.o\ 7 | ex_dfmt.o fp_dfmt.o fp2char_paded.o 8 | 9 | all: Q.o 10 | 11 | Q.o: $(OBJECTS) 12 | $(LD) -r -o Q.o $(OBJECTS) 13 | 14 | $(OBJECTS): ../include/apl.h ../include/format.h 15 | 16 | #Depends on char.h 17 | fpt2char.o fp2char_paded.o fp_digits.o: ../include/char.h 18 | 19 | .c.o: 20 | $(CC) $(CFLAGS) -c $< 21 | 22 | clean: 23 | rm -f *.o 24 | -------------------------------------------------------------------------------- /source/format/ex_dfmt.c: -------------------------------------------------------------------------------- 1 | /* openAPL, Copyright (C) Branko Bratkovic 1999 2 | * This file is free software and is covered by the GNU General 3 | * Public License. 4 | * 5 | * This program is distributed in the hope that it will be useful, 6 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 7 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. 8 | * 9 | * For more details see the GNU General Public License (GPL) in 10 | * the docs directory. 11 | */ 12 | 13 | #include "apl.h" 14 | #include "data.h" 15 | #include "utility.h" 16 | #include "format.h" 17 | 18 | /* dyadic format */ 19 | void ex_dfmt() 20 | { 21 | item_t *rp, *lp, *q; 22 | 23 | lp = fetch2(); 24 | rp = expr_stack_ptr[-2]; 25 | 26 | switch (lp->itemType) { 27 | case DA: 28 | break; 29 | 30 | case CH: 31 | error(ERR_domain, ""); 32 | break; 33 | 34 | default: 35 | error(ERR_botch, "attempt to format unsupported type"); 36 | } 37 | 38 | switch (rp->itemType) { 39 | case DA: 40 | /* convert rp from numeric to a literal array */ 41 | q = fp_dfmt(lp, rp); 42 | pop(); 43 | pop(); 44 | *expr_stack_ptr++ = q; // put it onto the expr_stack 45 | break; 46 | 47 | case CH: 48 | error(ERR_domain, ""); 49 | break; 50 | 51 | default: 52 | error(ERR_botch, "attempt to format unsupported type"); 53 | } 54 | } 55 | -------------------------------------------------------------------------------- /source/format/ex_mfmt.c: -------------------------------------------------------------------------------- 1 | /* openAPL, Copyright (C) Branko Bratkovic 1999 2 | * This file is free software and is covered by the GNU General 3 | * Public License. 4 | * 5 | * This program is distributed in the hope that it will be useful, 6 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 7 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. 8 | * 9 | * For more details see the GNU General Public License (GPL) in 10 | * the docs directory. 11 | */ 12 | 13 | #include "apl.h" 14 | #include "data.h" 15 | #include "utility.h" 16 | #include "format.h" 17 | 18 | /* monadic format */ 19 | void ex_mfmt() 20 | { 21 | item_t *p, *q; 22 | 23 | p = fetch1(); 24 | switch (p->itemType) { 25 | case DA: 26 | /* convert p from numeric to a literal array */ 27 | q = fp_mfmt(p); 28 | pop(); 29 | *expr_stack_ptr++ = q; // put it onto the expr_stack 30 | break; 31 | 32 | case CH: 33 | /* do nothing, pass p unchanged */ 34 | break; 35 | 36 | default: 37 | error(ERR_botch, "attempt to format unsupported type"); 38 | } 39 | } 40 | -------------------------------------------------------------------------------- /source/ibeam/Makefile: -------------------------------------------------------------------------------- 1 | # Makefile for I-Beam functions 2 | 3 | include ../include/makefile.common 4 | CFLAGS += -I../include 5 | 6 | OBJECTS = ex_dibm.o ex_mibm.o 7 | 8 | all: Q.o 9 | 10 | Q.o: $(OBJECTS) 11 | $(LD) -r -o Q.o $(OBJECTS) 12 | 13 | $(OBJECTS): ../include/apl.h 14 | 15 | .c.o: 16 | $(CC) $(CFLAGS) -c $< 17 | 18 | clean: 19 | rm -f $(OBJECTS) core 20 | 21 | -------------------------------------------------------------------------------- /source/ibeam/ex_dibm.c: -------------------------------------------------------------------------------- 1 | /* Copyright U S WEST Advanced Technologies, Inc. 2 | * You may use, copy, modify and sublicense this Software 3 | * subject to the conditions expressed in the file "License". 4 | */ 5 | #include 6 | 7 | #include "apl.h" 8 | #include "utility.h" 9 | #include "data.h" 10 | 11 | void ex_dibm() { 12 | int arg; 13 | item_t* p; 14 | 15 | /* Dyadic i-beam functions. I-beam 63 assumes that the 16 | * "empty" system call (check whether pipe empty) has been 17 | * implemented in the Unix kernel. 18 | */ 19 | 20 | arg = topfix(); /* Get left argument */ 21 | 22 | switch (topfix()) { 23 | 24 | default: 25 | error(ERR_implicit, "unknown i-beam"); 26 | 27 | case 34: /* "Nice" system call */ 28 | datum = nice(arg); 29 | break; 30 | 31 | case 35: /* "Sleep" system call */ 32 | datum = sleep(arg); 33 | break; 34 | 35 | case 63: /* "Empty" system call */ 36 | datum = empty(arg); 37 | break; 38 | } 39 | 40 | p = newdat(DA, 0, 1); 41 | p->datap[0] = datum; 42 | *expr_stack_ptr++ = p; 43 | } 44 | -------------------------------------------------------------------------------- /source/include/ascii_input.h: -------------------------------------------------------------------------------- 1 | /* ascii_input.h, Copyright (C) 2016, Greg Johnson 2 | * Released under the terms of the GNU GPL v2.0. 3 | * 4 | * This program is distributed in the hope that it will be useful, 5 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 6 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 7 | * GNU General Public License for more details. 8 | */ 9 | #ifndef ASCII_INPUT_H 10 | #define ASCII_INPUT_H 11 | 12 | char* to_ascii_input(char* input); 13 | char *toAplTouchtypeLine(char *inLine); 14 | 15 | #endif 16 | -------------------------------------------------------------------------------- /source/include/char.h: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/gregfjohnson/aplette/cc5009c197b182cbe3d3cc32a35594ced0bf9729/source/include/char.h -------------------------------------------------------------------------------- /source/include/config.h.in: -------------------------------------------------------------------------------- 1 | 2 | /* Define if you have readline */ 3 | #undef HAVE_LIBREADLINE 4 | -------------------------------------------------------------------------------- /source/include/data.h: -------------------------------------------------------------------------------- 1 | /* data.h, Copyright (C) 2016, Greg Johnson 2 | * Released under the terms of the GNU GPL v2.0. 3 | * 4 | * This program is distributed in the hope that it will be useful, 5 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 6 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 7 | * GNU General Public License for more details. 8 | */ 9 | #ifndef DATA_H 10 | #define DATA_H 11 | 12 | #include 13 | #include "apl.h" 14 | 15 | int access(); 16 | 17 | void bidx(item_t* ip); 18 | int copy(int type, char* from, char* to, int size); 19 | void colapse(int k); 20 | void putdat(item_t* ip, data d); 21 | void pop(); 22 | int size(); 23 | 24 | void indexIterateInit(DataIterator* iter); 25 | bool indexIterate(DataIterator* iter); 26 | 27 | void erase(SymTabEntry* np); 28 | 29 | item_t* newdat(ItemType type, int rank, int size); 30 | item_t* dupdat(item_t* ap); 31 | 32 | void symtab_init(); 33 | void symtab_clear(); 34 | SymTabEntry* symtabFind(char* name); 35 | SymTabEntry* symtabInsert(char* name); 36 | SymTabEntry* symtabEntryCreate(char* name); 37 | void symtabEntryInsert(SymTabEntry* entry); 38 | void symtabDelete(char* name); 39 | void symtabRemoveEntry(SymTabEntry* entry); 40 | 41 | void symtabIterateInit(); 42 | SymTabEntry* symtabIterate(); 43 | 44 | void initFunctionDefnSymbolTable(); 45 | 46 | #endif // DATA_H 47 | -------------------------------------------------------------------------------- /source/include/debug.h: -------------------------------------------------------------------------------- 1 | /* debug.h, Copyright (C) 2016, Greg Johnson 2 | * Released under the terms of the GNU GPL v2.0. 3 | * 4 | * This program is distributed in the hope that it will be useful, 5 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 6 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 7 | * GNU General Public License for more details. 8 | */ 9 | #ifndef DEBUG_H 10 | #define DEBUG_H 11 | 12 | #include "apl.h" 13 | 14 | void vars_dump(); 15 | void mem_dump(); 16 | void code_dump(char* cp, int flag); 17 | void stack_dump(); 18 | void parseDump(char* line, int len); 19 | char *ItemType_str(ItemType t); 20 | 21 | #endif 22 | -------------------------------------------------------------------------------- /source/include/execute.h: -------------------------------------------------------------------------------- 1 | /* execute.h, Copyright (C) 2016, Greg Johnson 2 | * Released under the terms of the GNU GPL v2.0. 3 | * 4 | * This program is distributed in the hope that it will be useful, 5 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 6 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 7 | * GNU General Public License for more details. 8 | */ 9 | #ifndef EXECUTE_H 10 | #define EXECUTE_H 11 | #include "apl.h" 12 | 13 | void execute(); 14 | void ex_dscal(int m, data (*f)(), item_t* p1, item_t* p2); 15 | 16 | void ex_cdyad(data (*f)(), item_t* ap, item_t* ap1); 17 | void ex_mdyad(data (*f)(), item_t* ap, item_t* ap1); 18 | void ex_ddyad(data (*f)(), item_t* ap, item_t* ap1); 19 | 20 | #endif 21 | -------------------------------------------------------------------------------- /source/include/format.h: -------------------------------------------------------------------------------- 1 | /* openAPL, Copyright (C) Branko Bratkovic 1999 2 | * This file is free software and is covered by the GNU General 3 | * Public License. 4 | * 5 | * This program is distributed in the hope that it will be useful, 6 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 7 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. 8 | * 9 | * For more details see the GNU General Public License (GPL) in 10 | * the docs directory. 11 | */ 12 | #ifndef FORMAT_H 13 | #define FORMAT_H 14 | 15 | struct FORMAT { 16 | int sign; /* 1 if space for a minus sign is required */ 17 | int exp; /* 1 if exponential format */ 18 | int left_ratn; /* number of left digits, rational format 19 | * ie, sign+left_digits */ 20 | int right_ratn; /* number of right digits, rational format 21 | * ie, right_digits */ 22 | int pp_ratn; /* Print Precision for rational format*/ 23 | int left_expn; /* number of left digits, expotential format 24 | * ie, sign+1 */ 25 | int right_expn; /* number of right digits, expotential format */ 26 | int digit_expn; /* number of digits in exponent inc sign & 'E' */ 27 | int digits; /* total field width */ 28 | struct FORMAT* next; /* linked list forward pointer */ 29 | }; 30 | 31 | extern char format_buffer[80]; 32 | void fp_digits(data d, struct FORMAT* format); 33 | char* fp2char(data d, struct FORMAT* format); 34 | char* fp2char_paded(data d, struct FORMAT* format); 35 | item_t* fp_mfmt(item_t* p); 36 | item_t* fp_dfmt(item_t* f, item_t* p); 37 | 38 | #endif 39 | -------------------------------------------------------------------------------- /source/include/getinput.h: -------------------------------------------------------------------------------- 1 | /* ascii_input.h, Copyright (C) 2016, Greg Johnson 2 | * Released under the terms of the GNU GPL v2.0. 3 | * 4 | * This program is distributed in the hope that it will be useful, 5 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 6 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 7 | * GNU General Public License for more details. 8 | */ 9 | #ifndef GETINPUT_H 10 | #define GETINPUT_H 11 | 12 | char* getinput(char* prompt); 13 | char* get_QuadInput(char* prompt); 14 | 15 | #endif 16 | -------------------------------------------------------------------------------- /source/include/main.h: -------------------------------------------------------------------------------- 1 | /* main.h, Copyright (C) 2016, Greg Johnson 2 | * Released under the terms of the GNU GPL v2.0. 3 | * 4 | * This program is distributed in the hope that it will be useful, 5 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 6 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 7 | * GNU General Public License for more details. 8 | */ 9 | #ifndef MAIN_LOOP_H 10 | #define MAIN_LOOP_H 11 | 12 | #include 13 | 14 | void mainloop(); 15 | void Exit(int s); 16 | 17 | char* to_ascii_input(char* input); 18 | void putAplTouchtypeChar(char c); 19 | char *toAplTouchtypeLine(char *inLine); 20 | 21 | extern FILE *quadInput; 22 | extern int stdin_isatty; 23 | 24 | extern int gbl_argc; 25 | extern char **gbl_argv; 26 | extern int gbl_optind; 27 | 28 | #endif 29 | -------------------------------------------------------------------------------- /source/include/makefile.common.in: -------------------------------------------------------------------------------- 1 | CC= @CC@ 2 | CFLAGS= @CFLAGS@ 3 | LIBS= @LIBS@ 4 | YACC= @YACC@ 5 | 6 | -------------------------------------------------------------------------------- /source/include/memory.h: -------------------------------------------------------------------------------- 1 | /* Copyright U S WEST Advanced Technologies, Inc. (AT&T) 2 | * You may use, copy, modify and sublicense this Software 3 | * subject to the conditions expressed in the file "License". 4 | */ 5 | #ifndef MEMORY_H 6 | #define MEMORY_H 7 | 8 | typedef struct memblock { 9 | int* block; 10 | unsigned nbytes; 11 | struct memblock* next; 12 | } memblock_t; 13 | 14 | extern memblock_t *firstblock; 15 | extern int mem_trace; 16 | 17 | void afreset(); 18 | void* alloc(unsigned bytes); 19 | void aplfree(void* ap); 20 | 21 | #endif 22 | -------------------------------------------------------------------------------- /source/include/mixed_dyadic.h: -------------------------------------------------------------------------------- 1 | /* mixed_dyadic.h, Copyright (C) 2016, Greg Johnson 2 | * Released under the terms of the GNU GPL v2.0. 3 | * 4 | * This program is distributed in the hope that it will be useful, 5 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 6 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 7 | * GNU General Public License for more details. 8 | */ 9 | #ifndef MIXED_DYADIC_H 10 | #define MIXED_DYADIC_H 11 | 12 | void ex_ddom(); 13 | void ex_elid(); 14 | 15 | #endif 16 | -------------------------------------------------------------------------------- /source/include/mixed_monadic.h: -------------------------------------------------------------------------------- 1 | /* mixed_monadic.h, Copyright (C) 2016, Greg Johnson 2 | * Released under the terms of the GNU GPL v2.0. 3 | * 4 | * This program is distributed in the hope that it will be useful, 5 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 6 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 7 | * GNU General Public License for more details. 8 | */ 9 | #ifndef MIXED_MONADIC_H 10 | #define MIXED_MONADIC_H 11 | 12 | void ex_execute(); 13 | 14 | #endif 15 | -------------------------------------------------------------------------------- /source/include/oper_dyadic.h: -------------------------------------------------------------------------------- 1 | /* oper_dyadic.h, Copyright (C) 2016, Greg Johnson 2 | * Released under the terms of the GNU GPL v2.0. 3 | * 4 | * This program is distributed in the hope that it will be useful, 5 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 6 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 7 | * GNU General Public License for more details. 8 | */ 9 | #ifndef OPER_DYADIC_H 10 | #define OPER_DYADIC_H 11 | 12 | void ex_iprod(); 13 | void ex_asgn(); 14 | 15 | #endif 16 | -------------------------------------------------------------------------------- /source/include/parser.h: -------------------------------------------------------------------------------- 1 | /* parser.h, Copyright (C) 2016, Greg Johnson 2 | * Released under the terms of the GNU GPL v2.0. 3 | * 4 | * This program is distributed in the hope that it will be useful, 5 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 6 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 7 | * GNU General Public License for more details. 8 | */ 9 | #ifndef PARSER_H 10 | #define PARSER_H 11 | 12 | char* compile_new(int f); 13 | char* compile_old(char* s, int f); 14 | void font_map_print(); 15 | extern int exprOrNullFlag; 16 | 17 | #endif 18 | -------------------------------------------------------------------------------- /source/include/print.h: -------------------------------------------------------------------------------- 1 | /* print.h, Copyright (C) 2016, Greg Johnson 2 | * Released under the terms of the GNU GPL v2.0. 3 | * 4 | * This program is distributed in the hope that it will be useful, 5 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 6 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 7 | * GNU General Public License for more details. 8 | */ 9 | #ifndef PRINT_H 10 | #define PRINT_H 11 | 12 | int ex_print(); 13 | int printLine(char *line); 14 | 15 | char c_overbar(void); 16 | 17 | #endif // PRINT_H 18 | -------------------------------------------------------------------------------- /source/include/quad_func.h: -------------------------------------------------------------------------------- 1 | /* quad_func.h, Copyright (C) 2016, Greg Johnson 2 | * Released under the terms of the GNU GPL v2.0. 3 | * 4 | * This program is distributed in the hope that it will be useful, 5 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 6 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 7 | * GNU General Public License for more details. 8 | */ 9 | #ifndef QUAD_FUNC_H 10 | #define QUAD_FUNC_H 11 | 12 | void eval_qlx(); 13 | 14 | #endif // QUAD_FUNC_H 15 | -------------------------------------------------------------------------------- /source/include/quad_var.h: -------------------------------------------------------------------------------- 1 | /* quad_var.h, Copyright (C) 2017, Greg Johnson 2 | * Released under the terms of the GNU GPL v2.0. 3 | * 4 | * This program is distributed in the hope that it will be useful, 5 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 6 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 7 | * GNU General Public License for more details. 8 | */ 9 | #ifndef QUAD_VAR_H 10 | #define QUAD_VAR_H 11 | 12 | #include "apl.h" 13 | 14 | void outputPrintP(); 15 | void updatePrintP(item_t *p); 16 | 17 | void outputPageWidth(); 18 | void updatePageWidth(item_t *p); 19 | 20 | #endif // QUAD_VAR_H 21 | -------------------------------------------------------------------------------- /source/include/userfunc.h: -------------------------------------------------------------------------------- 1 | /* userfunc.h, Copyright (C) 2016, Greg Johnson 2 | * Released under the terms of the GNU GPL v2.0. 3 | * 4 | * This program is distributed in the hope that it will be useful, 5 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 6 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 7 | * GNU General Public License for more details. 8 | */ 9 | #ifndef USERFUNC_H 10 | #define USERFUNC_H 11 | 12 | #include "apl.h" 13 | 14 | void tback(int flag); 15 | void sichk(SymTabEntry* n); 16 | int csize(char* s); 17 | void ex_nilret(); 18 | 19 | void funwrite(char* fname); 20 | void funedit(char* fname); 21 | int funread(char* fname); 22 | int fundef(int f); 23 | void funstdin(); 24 | void funcomp(SymTabEntry* np); 25 | void write_line(int fd, char *line); 26 | 27 | void ex_ibr0(); 28 | void ex_br(); 29 | void ex_br0(); 30 | 31 | void eval_qlx(); 32 | 33 | Context *Context_new(); 34 | void Context_free(Context *context); 35 | void Context_addShadowedId(Context *context, SymTabEntry *entry); 36 | 37 | #endif 38 | -------------------------------------------------------------------------------- /source/include/utility.h: -------------------------------------------------------------------------------- 1 | /* utility.h, Copyright (C) 2016, Greg Johnson 2 | * Released under the terms of the GNU GPL v2.0. 3 | * 4 | * This program is distributed in the hope that it will be useful, 5 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 6 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 7 | * GNU General Public License for more details. 8 | */ 9 | 10 | #ifndef UTILITY_H 11 | #define UTILITY_H 12 | #include 13 | #include "apl.h" 14 | 15 | void error(int type, char* diagnostic); 16 | int topfix(); 17 | int scalar(item_t* aip); 18 | void pline(char* str, int loc, int ln); 19 | int fix(data d); 20 | void checksp(); 21 | void fppinit(int arg); 22 | int fuzz(data d1, data d2); 23 | void map(int o); 24 | void iodone(int ok); 25 | int empty(int fd); 26 | int opn(char file[], int rw); 27 | double gamma(double arg); 28 | 29 | void intr(int s); 30 | void panic(int signum); 31 | void catchsigs(); 32 | 33 | void fappend(int fd, item_t* ap); 34 | char* readLine(char* title, char* xLine, int xLineLength, FILE* xInfile); 35 | 36 | #endif // UTILITY_H 37 | -------------------------------------------------------------------------------- /source/include/version.h: -------------------------------------------------------------------------------- 1 | ".29" 2 | -------------------------------------------------------------------------------- /source/include/work_space.h: -------------------------------------------------------------------------------- 1 | /* work_space.h, Copyright (C) 2016, Greg Johnson 2 | * Released under the terms of the GNU GPL v2.0. 3 | * 4 | * This program is distributed in the hope that it will be useful, 5 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 6 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 7 | * GNU General Public License for more details. 8 | */ 9 | #ifndef WORK_SPACE_H 10 | #define WORK_SPACE_H 11 | 12 | void wsload(int ffile); 13 | void wssave(int ffile); 14 | void clear(); 15 | 16 | void readErrorOnFailure(int fd, void* buf, size_t count); 17 | void writeErrorOnFailure(int fd, void* buf, size_t count); 18 | 19 | #endif 20 | -------------------------------------------------------------------------------- /source/main/Makefile: -------------------------------------------------------------------------------- 1 | # Makefile for main 2 | 3 | include ../include/makefile.common 4 | CFLAGS += -I../include 5 | 6 | OBJECTS = mainloop.o exit.o apl.o getinput.o history.o ascii_input.o 7 | 8 | all: Q.o 9 | 10 | Q.o: $(OBJECTS) 11 | $(LD) -r -o Q.o $(OBJECTS) 12 | 13 | $(OBJECTS): ../include/apl.h 14 | 15 | apl.o: ../include/version.h 16 | 17 | getinput.o: ../include/config.h 18 | 19 | .c.o: 20 | $(CC) $(CFLAGS) -c $< 21 | 22 | clean: 23 | rm -f $(OBJECTS) core 24 | 25 | -------------------------------------------------------------------------------- /source/main/exit.c: -------------------------------------------------------------------------------- 1 | /* Copyright U S WEST Advanced Technologies, Inc. 2 | * You may use, copy, modify and sublicense this Software 3 | * subject to the conditions expressed in the file "License". 4 | */ 5 | // #include 6 | #include 7 | #include 8 | #include 9 | #include "apl.h" 10 | 11 | void Exit(int s) 12 | { 13 | 14 | int j; 15 | 16 | for (j = 3; j < NFDS; j++) 17 | close(j); 18 | unlink(scr_file); 19 | free(scr_file); 20 | normalExit = 1; /* Set this flag for atexit() */ 21 | exit(s); /* And we're outa here */ 22 | } 23 | -------------------------------------------------------------------------------- /source/main/history.c: -------------------------------------------------------------------------------- 1 | /* history.c, Copyright (C) 2016, Greg Johnson 2 | * Released under the terms of the GNU GPL v2.0. 3 | * 4 | * This program is distributed in the hope that it will be useful, 5 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 6 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 7 | * GNU General Public License for more details. 8 | */ 9 | #include 10 | #include "config.h" 11 | 12 | #ifdef HAVE_LIBREADLINE 13 | #include 14 | 15 | void readline_add_history(char* line) 16 | { 17 | add_history(line); 18 | } 19 | #else 20 | void readline_add_history(char* line) 21 | { 22 | } 23 | #endif 24 | -------------------------------------------------------------------------------- /source/main/history.h: -------------------------------------------------------------------------------- 1 | /* history.h, Copyright (C) 2016, Greg Johnson 2 | * Released under the terms of the GNU GPL v2.0. 3 | * 4 | * This program is distributed in the hope that it will be useful, 5 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 6 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 7 | * GNU General Public License for more details. 8 | */ 9 | #ifndef HISTORY_H 10 | #define HISTORY_H 11 | 12 | void readline_add_history(char* line); 13 | 14 | #endif 15 | -------------------------------------------------------------------------------- /source/memory/DESIGN: -------------------------------------------------------------------------------- 1 | DYNAMIC MEMORY MANAGEMENT 2 | ------------------------- 3 | (This file consists of an attempt to analyse the memory 4 | management functions from apl\11.) 5 | 6 | Throughout the client routines, memory is obtained and released 7 | with alloc() and aplfree(). These are wrappers for malloc(3) 8 | and free(3) and include some additional overheads. 9 | 10 | The module afreset() is used by ws_clear... this provides the 11 | clue to the overheads. afreset() is able to clear all dynamic 12 | memory because a linked list of allocated blocks is maintained 13 | by alloc() and aplfree(). 14 | 15 | The clients which use these functions the most are in the 16 | ../data subdirectory. 17 | -------------------------------------------------------------------------------- /source/memory/Makefile: -------------------------------------------------------------------------------- 1 | # Makefile for memory 2 | 3 | include ../include/makefile.common 4 | CFLAGS += -I../include 5 | 6 | OBJECTS = afreset.o alloc.o aplfree.o memory.o 7 | 8 | all : Q.o 9 | 10 | Q.o: $(OBJECTS) 11 | $(LD) -r -o Q.o $(OBJECTS) 12 | 13 | $(OBJECTS): ../include/apl.h ../include/memory.h 14 | 15 | .c.o: 16 | $(CC) $(CFLAGS) -c $< 17 | 18 | clean: 19 | rm -f Q.o $(OBJECTS) core 20 | -------------------------------------------------------------------------------- /source/memory/afreset.c: -------------------------------------------------------------------------------- 1 | /* Copyright U S WEST Advanced Technologies, Inc. 2 | * You may use, copy, modify and sublicense this Software 3 | * subject to the conditions expressed in the file "License". 4 | */ 5 | 6 | #include 7 | #include "memory.h" 8 | 9 | void afreset() 10 | { 11 | struct memblock *item, *next_item; 12 | 13 | for (item = firstblock; item; item = next_item) { 14 | next_item = item->next; 15 | free(item->block); 16 | free(item); 17 | } 18 | firstblock = 0; 19 | } 20 | -------------------------------------------------------------------------------- /source/memory/alloc.c: -------------------------------------------------------------------------------- 1 | /* Copyright U S WEST Advanced Technologies, Inc. 2 | * You may use, copy, modify and sublicense this Software 3 | * subject to the conditions expressed in the file "License". 4 | */ 5 | 6 | #include 7 | #include 8 | #include 9 | #include "apl.h" 10 | #include "utility.h" 11 | #include "memory.h" 12 | 13 | void *alloc(unsigned nbytes) { 14 | struct memblock* newblock; 15 | 16 | if (nbytes <= 0) 17 | return 0; 18 | 19 | newblock = (struct memblock*)malloc(sizeof(struct memblock)); 20 | 21 | if (newblock == 0) 22 | goto failed; 23 | 24 | if (mem_trace) { 25 | printf("[alloc: %ld bytes at %p (memblock)", 26 | sizeof(struct memblock), (void *) newblock); 27 | } 28 | 29 | newblock->nbytes = nbytes; 30 | newblock->block = malloc(nbytes); 31 | 32 | if (newblock->block == 0) 33 | goto failed; 34 | 35 | bzero(newblock->block, nbytes); 36 | 37 | if (mem_trace) { 38 | printf(", %d bytes at %p (data)]\n", 39 | nbytes, (void *) newblock->block); 40 | } 41 | 42 | newblock->next = firstblock; 43 | firstblock = newblock; 44 | 45 | return newblock->block; 46 | 47 | failed: 48 | printf("Unable to obtain requested memory\n"); 49 | printf("%d bytes were requested\n", nbytes); 50 | error(ERR_interrupt, ""); 51 | 52 | // keep the compiler happy. It doesn't know that 53 | // error() never returns. 54 | return NULL; 55 | } 56 | -------------------------------------------------------------------------------- /source/memory/aplfree.c: -------------------------------------------------------------------------------- 1 | /* Copyright U S WEST Advanced Technologies, Inc. 2 | * You may use, copy, modify and sublicense this Software 3 | * subject to the conditions expressed in the file "License". 4 | */ 5 | 6 | #include 7 | #include 8 | #include 9 | #include "memory.h" 10 | 11 | void aplfree(void *ap) { 12 | struct memblock *item, *last; 13 | 14 | if (ap == 0) 15 | return; 16 | 17 | last = 0; 18 | for (item = firstblock; item; item = item->next) { 19 | if (item->block == ap) { 20 | if (last) 21 | last->next = item->next; 22 | else 23 | firstblock = item->next; 24 | 25 | if (mem_trace) { 26 | printf("[aplfree: %d bytes at %p (data)", 27 | item->nbytes, (void *) item->block); 28 | } 29 | free(item->block); 30 | 31 | if (mem_trace) { 32 | printf(", %ld bytes at %p (memblock)]\n", 33 | sizeof(struct memblock), (void *) item); 34 | } 35 | free(item); 36 | return; 37 | } 38 | last = item; 39 | } 40 | printf("aplfree bad block address %p\n", (void *) ap); 41 | } 42 | -------------------------------------------------------------------------------- /source/memory/memory.c: -------------------------------------------------------------------------------- 1 | #include "memory.h" 2 | 3 | memblock_t *firstblock; 4 | -------------------------------------------------------------------------------- /source/mixed_dyadic/Makefile: -------------------------------------------------------------------------------- 1 | # Makefile for mixed_dyadic (dyadic mixed functions) 2 | 3 | include ../include/makefile.common 4 | CFLAGS += -I../include 5 | 6 | OBJECTS = ex_base.o ex_index.o ex_tak_drp.o ex_ddom.o ex_diot.o \ 7 | ex_rep.o ex_trn.o ex_deal.o ex_eps.o ex_rot.o 8 | 9 | all: Q.o 10 | 11 | Q.o: $(OBJECTS) 12 | $(LD) -r -o Q.o $(OBJECTS) 13 | 14 | $(OBJECTS): ../include/apl.h 15 | 16 | ex_base.o ex_index.o: ../include/opt_codes.h 17 | 18 | .c.o: 19 | $(CC) $(CFLAGS) -c $< 20 | 21 | clean: 22 | rm -f $(OBJECTS) core Q.o 23 | -------------------------------------------------------------------------------- /source/mixed_dyadic/ex_base.c: -------------------------------------------------------------------------------- 1 | /* Copyright U S WEST Advanced Technologies, Inc. 2 | * You may use, copy, modify and sublicense this Software 3 | * subject to the conditions expressed in the file "License". 4 | */ 5 | 6 | #include "apl.h" 7 | #include "data.h" 8 | #include "utility.h" 9 | #include "opt_codes.h" 10 | #include "oper_dyadic.h" 11 | 12 | char base_com[] = { ADD, MUL }; 13 | 14 | void ex_base() 15 | { 16 | item_t* extend(); 17 | item_t *p, *q; 18 | int i; 19 | char* savptr; 20 | data d1, d2; 21 | 22 | p = fetch2(); 23 | q = expr_stack_ptr[-2]; 24 | if (p->itemType != DA || q->itemType != DA) 25 | error(ERR_domain, "base - incorrect types"); 26 | if (p->rank > 1) 27 | error(ERR_rank, "base - cannot handle left-arg-rank > 1"); 28 | if (scalar(p)) { 29 | if (q->rank > 0) 30 | i = q->dim[0]; 31 | else 32 | i = q->size; 33 | q = extend(DA, i, p->datap[0]); 34 | pop(); 35 | *expr_stack_ptr++ = p = q; 36 | q = expr_stack_ptr[-2]; 37 | } 38 | d1 = p->datap[p->size - 1]; 39 | p->datap[p->size - 1] = 1.0; 40 | for (i = p->size - 2; i >= 0; i--) { 41 | d2 = p->datap[i]; 42 | p->datap[i] = d1; 43 | d1 *= d2; 44 | } 45 | savptr = state_indicator_ptr->ptr; 46 | state_indicator_ptr->ptr = base_com; 47 | ex_iprod(); 48 | state_indicator_ptr->ptr = savptr; 49 | } 50 | -------------------------------------------------------------------------------- /source/mixed_dyadic/ex_deal.c: -------------------------------------------------------------------------------- 1 | /* Copyright U S WEST Advanced Technologies, Inc. 2 | * You may use, copy, modify and sublicense this Software 3 | * subject to the conditions expressed in the file "License". 4 | */ 5 | #include 6 | #include 7 | 8 | #include "apl.h" 9 | #include "utility.h" 10 | #include "data.h" 11 | 12 | void ex_deal() 13 | { 14 | item_t* p; 15 | int m, n; 16 | double f; 17 | data d1, d2; 18 | 19 | m = topfix(); 20 | n = topfix(); 21 | if (m < 0 || m > n) 22 | error(ERR_length, ""); 23 | p = newdat(DA, 1, m); 24 | datum = iorigin; 25 | for (; n != 0; n--) { 26 | f = m; 27 | f /= n; 28 | if (random() / (float)INT_MAX < f) { 29 | putdat(p, datum); 30 | m--; 31 | } 32 | datum += one; 33 | } 34 | m = p->size; 35 | while (m > 0) { 36 | f = random() / (float)INT_MAX; 37 | n = m * f; 38 | m--; 39 | if (n != m) { 40 | p->index = n; 41 | d1 = getdat(p); 42 | p->index = m; 43 | d2 = getdat(p); 44 | p->index = n; 45 | putdat(p, d2); 46 | p->index = m; 47 | putdat(p, d1); 48 | } 49 | } 50 | *expr_stack_ptr++ = p; 51 | } 52 | -------------------------------------------------------------------------------- /source/mixed_dyadic/ex_diot.c: -------------------------------------------------------------------------------- 1 | /* Copyright U S WEST Advanced Technologies, Inc. 2 | * You may use, copy, modify and sublicense this Software 3 | * subject to the conditions expressed in the file "License". 4 | */ 5 | 6 | #include "apl.h" 7 | #include "utility.h" 8 | #include "data.h" 9 | 10 | void ex_diot() 11 | { 12 | item_t *p, *q, *r; 13 | int i, j; 14 | 15 | p = fetch2(); 16 | q = expr_stack_ptr[-2]; 17 | r = newdat(DA, q->rank, q->size); 18 | copy(IN, (char*)q->dim, (char*)r->dim, q->rank); 19 | for (i = 0; i < q->size; i++) { 20 | datum = getdat(q); 21 | p->index = 0; 22 | for (j = 0; j < p->size; j++) 23 | if (fuzz(getdat(p), datum) == 0) 24 | break; 25 | datum = j + iorigin; 26 | putdat(r, datum); 27 | } 28 | pop(); 29 | pop(); 30 | *expr_stack_ptr++ = r; 31 | } 32 | -------------------------------------------------------------------------------- /source/mixed_dyadic/ex_eps.c: -------------------------------------------------------------------------------- 1 | /* Copyright U S WEST Advanced Technologies, Inc. 2 | * You may use, copy, modify and sublicense this Software 3 | * subject to the conditions expressed in the file "License". 4 | */ 5 | 6 | #include "apl.h" 7 | #include "utility.h" 8 | #include "data.h" 9 | 10 | void ex_eps() 11 | { 12 | item_t *p, *q, *r; 13 | int i, j; 14 | data d; 15 | 16 | p = fetch2(); 17 | q = expr_stack_ptr[-2]; 18 | r = newdat(DA, p->rank, p->size); 19 | copy(IN, (char*)p->dim, (char*)r->dim, p->rank); 20 | for (i = 0; i < p->size; i++) { 21 | datum = getdat(p); 22 | d = zero; 23 | q->index = 0; 24 | for (j = 0; j < q->size; j++) { 25 | if (fuzz(getdat(q), datum) == 0) { 26 | d = one; 27 | break; 28 | } 29 | } 30 | putdat(r, d); 31 | } 32 | pop(); 33 | pop(); 34 | *expr_stack_ptr++ = r; 35 | } 36 | -------------------------------------------------------------------------------- /source/mixed_dyadic/ex_rep.c: -------------------------------------------------------------------------------- 1 | /* Copyright U S WEST Advanced Technologies, Inc. 2 | * You may use, copy, modify and sublicense this Software 3 | * subject to the conditions expressed in the file "License". 4 | */ 5 | 6 | #include "apl.h" 7 | #include "data.h" 8 | double floor(); 9 | 10 | void ex_rep() 11 | { 12 | item_t *p, *q, *r; 13 | double d1, d2, d3; 14 | data *p1, *p2, *p3; 15 | 16 | p = fetch2(); 17 | q = expr_stack_ptr[-2]; 18 | /* 19 | * first map 1 element vectors to scalars: 20 | * 21 | if(scalar(p)) p->rank = 0; 22 | if(scalar(q)) q->rank = 0; 23 | */ 24 | r = newdat(DA, p->rank + q->rank, p->size * q->size); 25 | copy(IN, (char*)p->dim, (char*)r->dim, p->rank); 26 | // copy(IN, (char *)q->dim, (char *)(r->dim+p->rank), q->rank); 27 | copy(IN, (char*)q->dim, (char*)(r->dim + p->rank), q->rank); 28 | p3 = &r->datap[r->size]; 29 | for (p1 = &p->datap[p->size]; p1 > p->datap;) { 30 | d1 = *--p1; 31 | if (d1 == 0.0) 32 | d1 = 1.0e38; /* all else goes here */ 33 | for (p2 = &q->datap[q->size]; p2 > q->datap;) { 34 | d2 = *--p2; 35 | d3 = d2 /= d1; 36 | *p2 = d2 = floor(d2); 37 | *--p3 = (d3 - d2) * d1; 38 | } 39 | } 40 | pop(); 41 | pop(); 42 | *expr_stack_ptr++ = r; 43 | } 44 | -------------------------------------------------------------------------------- /source/mixed_monadic/Makefile: -------------------------------------------------------------------------------- 1 | # Makefile for mixed_monadic functions 2 | 3 | include ../include/makefile.common 4 | CFLAGS += -I../include 5 | 6 | OBJECTS = ex_menc.o ex_rand.o ex_mdom.o ex_execute.o ex_rev.o \ 7 | ex_gdu.o ex_gdd.o gd.o 8 | 9 | all : Q.o 10 | 11 | Q.o: $(OBJECTS) 12 | $(LD) -r -o Q.o $(OBJECTS) 13 | 14 | $(OBJECTS): ../include/apl.h 15 | 16 | .c.o: 17 | $(CC) $(CFLAGS) -c $< 18 | 19 | clean: 20 | rm -f *.o 21 | -------------------------------------------------------------------------------- /source/mixed_monadic/ex_gdd.c: -------------------------------------------------------------------------------- 1 | /* Copyright U S WEST Advanced Technologies, Inc. 2 | * You may use, copy, modify and sublicense this Software 3 | * subject to the conditions expressed in the file "License". 4 | */ 5 | 6 | #include "apl.h" 7 | #include "utility.h" 8 | #include "gd.h" 9 | 10 | int gdd(); 11 | 12 | void ex_gdd() 13 | { 14 | item_t* p; 15 | 16 | p = fetch1(); 17 | gd0(p->rank - 1, gdd); 18 | } 19 | 20 | void ex_gddk() 21 | { 22 | int k; 23 | 24 | k = topfix() - iorigin; 25 | fetch1(); 26 | gd0(k, gdd); 27 | } 28 | 29 | int gdd(int* p1, int* p2) 30 | { 31 | item_t* p; 32 | data d1, d2; 33 | 34 | p = expr_stack_ptr[-2]; 35 | p->index = integ + *p1 * idx.delk; 36 | d1 = getdat(p); 37 | p->index = integ + *p2 * idx.delk; 38 | d2 = getdat(p); 39 | if (fuzz(d1, d2) != 0) { 40 | if (d1 > d2) 41 | return (-1); 42 | return (1); 43 | } 44 | return (*p1 - *p2); 45 | } 46 | -------------------------------------------------------------------------------- /source/mixed_monadic/ex_gdu.c: -------------------------------------------------------------------------------- 1 | /* Copyright U S WEST Advanced Technologies, Inc. 2 | * You may use, copy, modify and sublicense this Software 3 | * subject to the conditions expressed in the file "License". 4 | */ 5 | 6 | #include "apl.h" 7 | #include "utility.h" 8 | #include "gd.h" 9 | 10 | int gdu(const int* p1, const int* p2); 11 | 12 | void ex_gdu() 13 | { 14 | item_t* p; 15 | 16 | p = fetch1(); 17 | gd0(p->rank - 1, (int (*)(const void*, const void*))gdu); 18 | } 19 | 20 | void ex_gduk() 21 | { 22 | int k; 23 | 24 | k = topfix() - iorigin; 25 | fetch1(); 26 | gd0(k, (int (*)(const void*, const void*))gdu); 27 | } 28 | 29 | int gdu(const int* p1, const int* p2) 30 | { 31 | item_t* p; 32 | data d1, d2; 33 | 34 | p = expr_stack_ptr[-2]; 35 | p->index = integ + *p1 * idx.delk; 36 | d1 = getdat(p); 37 | p->index = integ + *p2 * idx.delk; 38 | d2 = getdat(p); 39 | if (fuzz(d1, d2) != 0) { 40 | if (d1 > d2) 41 | return (1); 42 | return (-1); 43 | } 44 | return (*p1 - *p2); 45 | } 46 | -------------------------------------------------------------------------------- /source/mixed_monadic/ex_mdom.c: -------------------------------------------------------------------------------- 1 | /* Copyright U S WEST Advanced Technologies, Inc. 2 | * You may use, copy, modify and sublicense this Software 3 | * subject to the conditions expressed in the file "License". 4 | */ 5 | 6 | #include "apl.h" 7 | #include "utility.h" 8 | #include "data.h" 9 | #include "mixed_dyadic.h" 10 | 11 | void ex_mdom() 12 | { 13 | data* dp; 14 | int a, i, j; 15 | item_t *p, *q; 16 | 17 | p = fetch1(); 18 | if (p->rank != 2) 19 | error(ERR_rank, ""); 20 | a = p->dim[0]; 21 | q = newdat(DA, 2, a * a); 22 | q->dim[0] = a; 23 | q->dim[1] = a; 24 | *expr_stack_ptr++ = q; 25 | dp = q->datap; 26 | for (i = 0; i < a; i++) { 27 | for (j = 0; j < a; j++) { 28 | datum = zero; 29 | if (i == j) 30 | datum = one; 31 | *dp++ = datum; 32 | } 33 | } 34 | ex_ddom(); 35 | } 36 | -------------------------------------------------------------------------------- /source/mixed_monadic/ex_menc.c: -------------------------------------------------------------------------------- 1 | /* Copyright U S WEST Advanced Technologies, Inc. 2 | * You may use, copy, modify and sublicense this Software 3 | * subject to the conditions expressed in the file "License". 4 | */ 5 | 6 | #include "apl.h" 7 | #include "utility.h" 8 | 9 | /* monadic encode */ 10 | void ex_menc() 11 | { 12 | error(ERR, "Monadic encode not supported"); 13 | } 14 | -------------------------------------------------------------------------------- /source/mixed_monadic/ex_rand.c: -------------------------------------------------------------------------------- 1 | /* Copyright U S WEST Advanced Technologies, Inc. 2 | * You may use, copy, modify and sublicense this Software 3 | * subject to the conditions expressed in the file "License". 4 | */ 5 | #include 6 | #include 7 | #include 8 | 9 | #include "apl.h" 10 | 11 | double floor(); 12 | 13 | data ex_rand(data d) 14 | { 15 | double f; 16 | 17 | f = (random() / (float)INT_MAX) * d; 18 | d = floor(f) + iorigin; 19 | return (d); 20 | } 21 | -------------------------------------------------------------------------------- /source/mixed_monadic/ex_rev.c: -------------------------------------------------------------------------------- 1 | /* Copyright U S WEST Advanced Technologies, Inc. 2 | * You may use, copy, modify and sublicense this Software 3 | * subject to the conditions expressed in the file "License". 4 | */ 5 | 6 | #include "apl.h" 7 | #include "utility.h" 8 | #include "data.h" 9 | 10 | void revk(int k); 11 | 12 | void ex_rev0() 13 | { 14 | fetch1(); 15 | revk(0); 16 | } 17 | 18 | void ex_revk() 19 | { 20 | int k; 21 | 22 | k = topfix() - iorigin; 23 | fetch1(); 24 | revk(k); 25 | } 26 | 27 | void ex_rev() 28 | { 29 | item_t* p; 30 | 31 | p = fetch1(); 32 | revk(p->rank - 1); 33 | } 34 | 35 | void revk(int k) 36 | { 37 | int o; 38 | 39 | bidx(expr_stack_ptr[-1]); 40 | if (k < 0 || k >= idx.rank) 41 | error(ERR_index, ""); 42 | o = idx.del[k] * (idx.dim[k] - 1); 43 | idx.del[k] = -idx.del[k]; 44 | map(o); 45 | } 46 | -------------------------------------------------------------------------------- /source/mixed_monadic/gd.c: -------------------------------------------------------------------------------- 1 | /* Copyright U S WEST Advanced Technologies, Inc. 2 | * You may use, copy, modify and sublicense this Software 3 | * subject to the conditions expressed in the file "License". 4 | */ 5 | #include 6 | 7 | /* gd0 and gd1 are used by both grade up and grade down */ 8 | 9 | static void gd1(int* m, int (*f)(const void*, const void*)); 10 | 11 | #include "apl.h" 12 | #include "utility.h" 13 | #include "data.h" 14 | #include "memory.h" 15 | 16 | void gd0(int k, int (*f)(const void*, const void*)) 17 | { 18 | item_t* p; 19 | int* intvec; 20 | 21 | bidx(expr_stack_ptr[-1]); 22 | if (k < 0 || k >= idx.rank) 23 | error(ERR_index, ""); 24 | p = newdat(DA, idx.rank, idx.size); 25 | copy(IN, (char*)idx.dim, (char*)p->dim, idx.rank); 26 | *expr_stack_ptr++ = p; 27 | colapse(k); 28 | 29 | intvec = (int*)alloc(idx.dimk * SINT); 30 | 31 | indexIterateInit(&idx); 32 | while (indexIterate(&idx)) { 33 | gd1(intvec, f); 34 | } 35 | 36 | aplfree(intvec); 37 | p = expr_stack_ptr[-1]; 38 | expr_stack_ptr--; 39 | pop(); 40 | *expr_stack_ptr++ = p; 41 | } 42 | 43 | static void gd1(int* m, int (*f)(const void*, const void*)) 44 | { 45 | item_t* p; 46 | int i, *m1; 47 | 48 | integ = access(); 49 | m1 = m; 50 | for (i = 0; i < idx.dimk; i++) 51 | *m1++ = i; 52 | qsort(m, idx.dimk, SINT, (int (*)(const void*, const void*))f); 53 | p = expr_stack_ptr[-1]; 54 | for (i = 0; i < idx.dimk; i++) { 55 | p->index = integ; 56 | datum = *m++ + iorigin; 57 | putdat(p, datum); 58 | integ += idx.delk; 59 | } 60 | } 61 | -------------------------------------------------------------------------------- /source/mixed_monadic/gd.h: -------------------------------------------------------------------------------- 1 | /* gd.h, Copyright (C) 2016, Greg Johnson 2 | * Released under the terms of the GNU GPL v2.0. 3 | * 4 | * This program is distributed in the hope that it will be useful, 5 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 6 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 7 | * GNU General Public License for more details. 8 | */ 9 | #ifndef GD_H 10 | #define GD_H 11 | 12 | void gd0(int k, int (*f)(const void*, const void*)); 13 | 14 | #endif 15 | -------------------------------------------------------------------------------- /source/oper_dyadic/Makefile: -------------------------------------------------------------------------------- 1 | # Makefile for oper_dyadic (dyadic operators) 2 | 3 | include ../include/makefile.common 4 | CFLAGS += -I../include 5 | 6 | OBJECTS = ex_iprod.o ex_oprod.o ex_asgn.o 7 | 8 | all: Q.o 9 | 10 | Q.o: $(OBJECTS) 11 | $(LD) -r -o Q.o $(OBJECTS) 12 | 13 | $(OBJECTS): ../include/apl.h 14 | 15 | ex_asgn.o: ../include/char.h 16 | 17 | .c.o: 18 | $(CC) $(CFLAGS) -c $< 19 | 20 | clean: 21 | rm -f $(OBJECTS) core Q.o 22 | -------------------------------------------------------------------------------- /source/oper_dyadic/ex_oprod.c: -------------------------------------------------------------------------------- 1 | /* Copyright U S WEST Advanced Technologies, Inc. 2 | * You may use, copy, modify and sublicense this Software 3 | * subject to the conditions expressed in the file "License". 4 | */ 5 | #include 6 | #include "apl.h" 7 | #include "utility.h" 8 | #include "data.h" 9 | 10 | void ex_oprod() 11 | { 12 | int i, j; 13 | data *dp, *dp1, *dp2; 14 | item_t *p, *q, *r; 15 | data (*f)(); 16 | 17 | f = (data(*)()) exop[(uint32_t) *state_indicator_ptr->ptr++]; 18 | p = fetch2(); 19 | q = expr_stack_ptr[-2]; 20 | if (p->itemType != DA || q->itemType != DA) 21 | error(ERR_domain, "not numeric data"); 22 | /* 23 | * collapse 1 element vectors to scalars 24 | * 25 | if(scalar(p)) p->rank = 0; 26 | if(scalar(q)) q->rank = 0; 27 | */ 28 | bidx(p); 29 | for (i = 0; i < q->rank; i++) 30 | idx.dim[idx.rank++] = q->dim[i]; 31 | r = newdat(DA, idx.rank, size()); 32 | copy(IN, (char*)idx.dim, (char*)r->dim, idx.rank); 33 | dp = r->datap; 34 | dp1 = p->datap; 35 | for (i = 0; i < p->size; i++) { 36 | datum = *dp1++; 37 | dp2 = q->datap; 38 | for (j = 0; j < q->size; j++) 39 | *dp++ = (*f)(datum, *dp2++); 40 | } 41 | pop(); 42 | pop(); 43 | *expr_stack_ptr++ = r; 44 | } 45 | -------------------------------------------------------------------------------- /source/oper_monadic/Makefile: -------------------------------------------------------------------------------- 1 | # Makefile for oper_monadic (monadic operators) 2 | 3 | include ../include/makefile.common 4 | CFLAGS += -I../include 5 | 6 | OBJECTS = ex_red.o ex_com.o ex_exd.o ex_scan.o 7 | 8 | all: Q.o 9 | 10 | Q.o: $(OBJECTS) 11 | $(LD) -r -o Q.o $(OBJECTS) 12 | 13 | $(OBJECTS): ../include/apl.h 14 | 15 | ex_red.o ex_scan.o: ../include/opt_codes.h 16 | 17 | .c.o: 18 | $(CC) $(CFLAGS) -c $< 19 | 20 | clean: 21 | rm -f $(OBJECTS) 22 | -------------------------------------------------------------------------------- /source/parser/Makefile: -------------------------------------------------------------------------------- 1 | # Makefile for parser 2 | 3 | include ../include/makefile.common 4 | CFLAGS += -I../include 5 | 6 | OBJECTS = alpha.o genlab.o getquad.o name.o \ 7 | compile_old.o compile_new.o getnam.o invert.o yyerror.o \ 8 | digit.o getnum.o yylex.o \ 9 | font_map.o \ 10 | table_oper.o table_comm.o table_quad.o \ 11 | lastcode.o y.tab.o local_parser.o 12 | 13 | all: Q.o 14 | 15 | Q.o: $(OBJECTS) 16 | $(LD) -r -o Q.o $(OBJECTS) 17 | 18 | $(OBJECTS): ../include/apl.h local_parser.h 19 | 20 | genlab.o compile_old.o compile_new.o yylex.o lastcode.o apl.y \ 21 | table_comm.o table_oper.o table_quad.o: ../include/opt_codes.h 22 | 23 | y.tab.o: y.tab.c 24 | $(CC) $(CFLAGS) -c y.tab.c 25 | 26 | y.tab.c y.tab.h: apl.y 27 | $(if $(YACC),$(YACC) -d apl.y,touch y.tab.c y.tab.h) 28 | 29 | .c.o: 30 | $(CC) $(CFLAGS) -c $< 31 | 32 | getquad.o compile_old.o compile_new.o getnam.o getnum.o yylex.o \ 33 | table_oper.o table_comm.o table_quad.o: y.tab.h 34 | 35 | getnum.o yylex.o table_oper.o: ../include/char.h 36 | 37 | clean: 38 | rm -f $(OBJECTS) core Q.o 39 | -------------------------------------------------------------------------------- /source/parser/alpha.c: -------------------------------------------------------------------------------- 1 | /* Copyright U S WEST Advanced Technologies, Inc. 2 | * You may use, copy, modify and sublicense this Software 3 | * subject to the conditions expressed in the file "License". 4 | */ 5 | 6 | #include "local_parser.h" 7 | 8 | bool alpha(char s) 9 | { 10 | return ( 11 | (s >= 'a' && s <= 'z') 12 | || (s >= 'A' && s <= 'Z') 13 | || (litflag == -2 && (s == '/' || s == '.'))); 14 | } 15 | -------------------------------------------------------------------------------- /source/parser/alpha.h: -------------------------------------------------------------------------------- 1 | /* alpha.h, Copyright (C) 2016, Greg Johnson 2 | * Released under the terms of the GNU GPL v2.0. 3 | * 4 | * This program is distributed in the hope that it will be useful, 5 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 6 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 7 | * GNU General Public License for more details. 8 | */ 9 | #ifndef ALPHA_H 10 | #define ALPHA_H 11 | 12 | #include 13 | 14 | bool alpha(int s); 15 | 16 | #endif 17 | -------------------------------------------------------------------------------- /source/parser/compile_old.c: -------------------------------------------------------------------------------- 1 | /* Copyright U S WEST Advanced Technologies, Inc. 2 | * You may use, copy, modify and sublicense this Software 3 | * subject to the conditions expressed in the file "License". 4 | */ 5 | 6 | #include "utility.h" 7 | #include "local_parser.h" 8 | #include "y.tab.h" 9 | #include "opt_codes.h" 10 | #include "memory.h" 11 | #include "debug.h" 12 | #include "ascii_input.h" 13 | 14 | /* s is statement 15 | * f is execution flag: 16 | * 0 compile immediate 17 | * 1 compile quad input 18 | * 2 function definition 19 | * 3 function prolog 20 | * 4 function epilog 21 | * 5 function body 22 | */ 23 | extern int ilex[]; 24 | 25 | char* compile_old(char* s, int f) 26 | { 27 | int i; 28 | 29 | iline = s; 30 | ccharp = oline; 31 | litflag = 0; 32 | nlexsym = ilex[f]; 33 | context = nlexsym; 34 | compilePhase = (CompilePhase)f; 35 | 36 | if (code_trace) { 37 | char *line = toAplTouchtypeLine(iline); 38 | fprintf(stderr, "\n\nabout to yyparse.. iline: >>%s<<\n\n", line); 39 | aplfree(line); 40 | } 41 | 42 | if (yyparse()) { 43 | pline(s, iline - s, lineNumber); //print line and error pointer 44 | return (0); 45 | } 46 | *ccharp++ = END; 47 | 48 | parseDump(oline, ccharp - oline); 49 | 50 | iline = (char*) alloc(ccharp - oline); 51 | 52 | for (i = 0; i < ccharp - oline; ++i) { 53 | iline[i] = oline[i]; 54 | } 55 | 56 | return (iline); 57 | } 58 | -------------------------------------------------------------------------------- /source/parser/digit.c: -------------------------------------------------------------------------------- 1 | /* Copyright U S WEST Advanced Technologies, Inc. 2 | * You may use, copy, modify and sublicense this Software 3 | * subject to the conditions expressed in the file "License". 4 | */ 5 | 6 | #include "local_parser.h" 7 | 8 | int digit(char s) 9 | { 10 | if (s >= '0' && s <= '9') 11 | return (1); 12 | return (0); 13 | } 14 | 15 | int isodigit(char c) 16 | { 17 | if (c < '0') 18 | return 0; 19 | if (c > '7') 20 | return 0; 21 | return 1; 22 | } 23 | -------------------------------------------------------------------------------- /source/parser/genlab.c: -------------------------------------------------------------------------------- 1 | /* Copyright U S WEST Advanced Technologies, Inc. 2 | * You may use, copy, modify and sublicense this Software 3 | * subject to the conditions expressed in the file "License". 4 | */ 5 | 6 | #include "local_parser.h" 7 | #include "opt_codes.h" 8 | #include "data.h" 9 | 10 | /* 11 | * genlab -- generates label code onto label stacks. 12 | * 13 | * prologue: AUTO-lab, CONST-linenum, NAME-lab LABEL END 14 | * 15 | * epilog: REST-lab END 16 | */ 17 | void genlab(SymTabEntry* np) { 18 | data lnumb; 19 | 20 | // label prologue 21 | 22 | *labcpp++ = AUTO; 23 | labcpp += copy(PTR, (char*)&np, (char*)labcpp, 1); 24 | 25 | *labcpp++ = CONST; 26 | *labcpp++ = 1; 27 | lnumb = (data)lineNumber; 28 | labcpp += copy(DA, (char*)&lnumb, (char*)labcpp, 1); 29 | 30 | *labcpp++ = NAME; 31 | labcpp += copy(PTR, (char*)&np, (char*)labcpp, 1); 32 | 33 | *labcpp++ = LABEL; 34 | 35 | *labcpp = END; 36 | 37 | // label epilog 38 | 39 | *labcpe++ = REST; 40 | labcpe += copy(PTR, (char*)&np, (char*)labcpe, 1); 41 | 42 | *labcpe = END; 43 | } 44 | -------------------------------------------------------------------------------- /source/parser/getquad.c: -------------------------------------------------------------------------------- 1 | /* Copyright U S WEST Advanced Technologies, Inc. 2 | * You may use, copy, modify and sublicense this Software 3 | * subject to the conditions expressed in the file "License". 4 | */ 5 | 6 | #include "local_parser.h" 7 | #include "y.tab.h" 8 | 9 | extern struct QUOD qtab[]; 10 | #define lv yylval 11 | 12 | int getquad() 13 | { 14 | char* p1; 15 | struct QUOD* p2; 16 | char qbuf[10]; 17 | 18 | p1 = qbuf; 19 | while (alpha(*iline)) 20 | *p1++ = *iline++; 21 | *p1++ = 0; 22 | if (*qbuf == 0) 23 | return (q_var); /* ordinary quad variable*/ 24 | for (p2 = qtab; p2->qname; p2++) { 25 | if (equal(p2->qname, qbuf)) { 26 | lv.charval = p2->qtype; 27 | return (p2->rtype); 28 | } 29 | } 30 | return (unk); 31 | } 32 | -------------------------------------------------------------------------------- /source/parser/invert.c: -------------------------------------------------------------------------------- 1 | /* Copyright U S WEST Advanced Technologies, Inc. 2 | * You may use, copy, modify and sublicense this Software 3 | * subject to the conditions expressed in the file "License". 4 | */ 5 | 6 | #include "local_parser.h" 7 | 8 | static void flop(char* a, char* b) 9 | { 10 | char *a1, *a2; 11 | int c; 12 | 13 | a1 = a; 14 | a2 = b; 15 | while (a1 < a2) { 16 | c = *a1; 17 | *a1++ = *--a2; 18 | *a2 = c; 19 | } 20 | } 21 | 22 | void invert(char* a, char* b) 23 | { 24 | flop(a, b); 25 | flop(b, ccharp); 26 | flop(a, ccharp); 27 | } 28 | -------------------------------------------------------------------------------- /source/parser/lastcode.c: -------------------------------------------------------------------------------- 1 | /* Copyright U S WEST Advanced Technologies, Inc. 2 | * You may use, copy, modify and sublicense this Software 3 | * subject to the conditions expressed in the file "License". 4 | */ 5 | 6 | #include "apl.h" 7 | #include "opt_codes.h" 8 | 9 | int lastCode(char* s) 10 | { 11 | int code, j, last; 12 | 13 | code = 0; 14 | last = 0; 15 | loop: 16 | if (code && code != EOL && code != END) 17 | last = code; 18 | code = *s++; 19 | //if(code != END) code &= 0377; 20 | switch (code) { 21 | 22 | case EOL: 23 | if (*s != EOL) 24 | break; 25 | case END: 26 | return last; 27 | 28 | case QUOT: 29 | j = *s++; 30 | s += j; 31 | break; 32 | 33 | case CONST: 34 | j = *s++; 35 | s += j * SDAT; 36 | break; 37 | 38 | case NAME: 39 | case FUN: 40 | case ARG1: 41 | case ARG2: 42 | case AUTO: 43 | case REST: 44 | case RVAL: 45 | s += SPTR; 46 | break; 47 | 48 | case INDEX: 49 | case IMMED: 50 | s++; 51 | break; 52 | } 53 | goto loop; 54 | } 55 | -------------------------------------------------------------------------------- /source/parser/local_parser.c: -------------------------------------------------------------------------------- 1 | #include "local_parser.h" 2 | 3 | int vcount; 4 | int scount; 5 | int litflag; 6 | int exprOrNullFlag; 7 | int nlexsym; 8 | int context; 9 | char* iline; 10 | char *ccharp, *ccharp2; 11 | data lnumb; /* current label number */ 12 | char* labcpp; /* label prologue */ 13 | char* labcpe; /* label epilogue */ 14 | int immedcmd; /* immediate command number */ 15 | char oline[OBJS]; 16 | -------------------------------------------------------------------------------- /source/parser/local_parser.h: -------------------------------------------------------------------------------- 1 | /* Copyright U S WEST Advanced Technologies, Inc. (AT&T) 2 | * You may use, copy, modify and sublicense this Software 3 | * subject to the conditions expressed in the file "License". 4 | */ 5 | #ifndef LOCAL_PARSER_H 6 | #define LOCAL_PARSER_H 7 | 8 | #include 9 | #include "../include/apl.h" 10 | 11 | extern int vcount; 12 | extern int scount; 13 | extern int litflag; 14 | extern int exprOrNullFlag; 15 | extern int nlexsym; 16 | extern int context; 17 | extern char* iline; 18 | extern char *ccharp, *ccharp2; 19 | extern data lnumb; /* current label number */ 20 | extern char* labcpp; /* label prologue */ 21 | extern char* labcpe; /* label epilogue */ 22 | extern int immedcmd; /* immediate command number */ 23 | extern char oline[OBJS]; 24 | 25 | int yylex(); 26 | 27 | char* name(char* np, char c); 28 | bool alpha(char s); 29 | int digit(char s); 30 | int isodigit(char c); 31 | int getquad(); 32 | void yyerror(char* error); 33 | void genlab(SymTabEntry* np); 34 | void invert(char* a, char* b); 35 | int getnum(char ic); 36 | int getnam(char ic); 37 | int lastCode(char* s); 38 | 39 | struct OPER { 40 | int input; 41 | int lexval; 42 | int retval; 43 | }; 44 | 45 | struct COMM { 46 | char* ct_name; /* command name string */ 47 | int ct_ytype; /* command type */ 48 | int ct_ylval; /* "yylval" value */ 49 | }; 50 | 51 | struct QUOD { 52 | char* qname; 53 | int qtype; 54 | int rtype; 55 | }; 56 | 57 | #endif 58 | -------------------------------------------------------------------------------- /source/parser/name.c: -------------------------------------------------------------------------------- 1 | /* Copyright U S WEST Advanced Technologies, Inc. 2 | * You may use, copy, modify and sublicense this Software 3 | * subject to the conditions expressed in the file "License". 4 | */ 5 | #include "data.h" 6 | #include "local_parser.h" 7 | #include "debug.h" 8 | 9 | char* name(char* np, char c) 10 | { 11 | char* p = ccharp; 12 | 13 | *ccharp++ = c; 14 | copy(PTR, (char*)&np, ccharp, 1); 15 | ccharp += SPTR; 16 | 17 | parseDump(oline, ccharp - oline); 18 | 19 | return p; 20 | } 21 | -------------------------------------------------------------------------------- /source/parser/table_comm.c: -------------------------------------------------------------------------------- 1 | /* Copyright U S WEST Advanced Technologies, Inc. 2 | * You may use, copy, modify and sublicense this Software 3 | * subject to the conditions expressed in the file "License". 4 | */ 5 | 6 | #include "char.h" 7 | #include "local_parser.h" 8 | #include "y.tab.h" 9 | #include "opt_codes.h" 10 | 11 | struct COMM comtab[] = { 12 | { "clear", comnull, CLEAR }, 13 | { "continue", comnull, CONTIN }, 14 | { "copy", comnam, COPY }, 15 | { "debug", comnull, DEBUG }, 16 | { "drop", comlist, DROPC }, 17 | { "font", comnull, FONT }, 18 | { "license", comnull, LICENSE }, 19 | { "edit", comnam, EDIT }, 20 | { "write", comnam, WRITE }, 21 | { "trace", comnull, TRACE }, 22 | { "untrace", comnull, UNTRACE }, 23 | { "erase", comlist, ERASE }, 24 | { "fns", comnull, FNS }, 25 | { "lib", comnull, LIB }, 26 | { "load", comnam, LOAD }, 27 | { "off", comnull, OFF }, 28 | { "read", comnam, READ }, 29 | { "save", comnam, SAVE }, 30 | { "vars", comnull, VARS }, 31 | { "script", comnam, SCRIPT }, 32 | { "si", comnull, SICOM }, 33 | { "sic", comnull, SICLEAR }, 34 | { "code", comnam, CODE }, 35 | { "shell", comnull, SHELL }, 36 | { "list", comnam, LIST }, 37 | { "prws", comnull, PRWS }, 38 | { "memory", comnull, MEMORY }, 39 | { "digits", comExprOrNull, DIGITS }, 40 | { "width", comExprOrNull, WIDTH }, 41 | { 0, unk } 42 | }; 43 | -------------------------------------------------------------------------------- /source/parser/table_quad.c: -------------------------------------------------------------------------------- 1 | /* Copyright U S WEST Advanced Technologies, Inc. 2 | * You may use, copy, modify and sublicense this Software 3 | * subject to the conditions expressed in the file "License". 4 | */ 5 | 6 | #include "char.h" 7 | #include "local_parser.h" 8 | #include "y.tab.h" 9 | #include "opt_codes.h" 10 | 11 | /* 12 | * qtab -- table of valid quad variables and quad functions 13 | * the format of the qtab is the similar to tab, above 14 | * 15 | */ 16 | struct QUOD qtab[] = { 17 | { "lx", QLX, q_var }, 18 | { "av", QAV, q_var }, 19 | { "ai", QAI, q_var }, 20 | { "argv", QARGV, q_var }, 21 | { "ts", QTS, q_var }, 22 | { "pp", QPP, q_var }, 23 | { "pw", QPW, q_var }, 24 | { "ct", QCT, q_var }, 25 | { "io", QIO, q_var }, 26 | { "run", QRUN, m }, 27 | { "fork", QFORK, m }, 28 | { "wait", QWAIT, m }, 29 | { "exec", QEXEC, m }, 30 | { "cr", QCRP, m }, 31 | { "fx", FDEF, m }, 32 | { "exit", QEXIT, m }, 33 | { "pipe", QPIPE, m }, 34 | { "chdir", QCHDIR, m }, 35 | { "open", QOPEN, d }, 36 | { "close", QCLOSE, m }, 37 | { "read", QREAD, d }, 38 | { "write", QWRITE, d }, 39 | { "creat", QCREAT, d }, 40 | { "seek", QSEEK, m }, 41 | { "kill", QKILL, d }, 42 | { "rd", QRD, m }, 43 | { "rm", QUNLNK, m }, 44 | { "dup", QDUP, m }, 45 | { "ap", QAP, d }, 46 | { "nc", QNC, m }, 47 | { "sig", QSIGNL, d }, 48 | { "float", QFLOAT, m }, 49 | { "nl", QNL, m }, 50 | { "ex", QEX, m }, 51 | { 0, 0, 0 } 52 | }; 53 | -------------------------------------------------------------------------------- /source/parser/yyerror.c: -------------------------------------------------------------------------------- 1 | /* Copyright U S WEST Advanced Technologies, Inc. 2 | * You may use, copy, modify and sublicense this Software 3 | * subject to the conditions expressed in the file "License". 4 | */ 5 | 6 | void yyerror(char* error) 7 | { 8 | } 9 | -------------------------------------------------------------------------------- /source/print/DESIGN: -------------------------------------------------------------------------------- 1 | PRINT ROUTINES 2 | -------------- 3 | The entry points for most print tasks are ex_print and 4 | ex_hprint. These call print() which coordinates most of 5 | the real work. 6 | 7 | Stage 1. The top of the expr_stack is fetch()'ed - so it 8 | stays on the expr_stack and if it is a quad function or 9 | variable, fetch() will convert it into a number. For 10 | data types, fpt_size() is called with every member of the 11 | item as an argument. The goal of this process is to 12 | calculate 4 parameters held in the structure "format" 13 | Next fpt_adjust() is called to determine the width of 14 | the print fields - each numeral will subsequently be printed 15 | in an identical field width. 16 | 17 | not sure what bidx does!! 18 | 19 | Stage 2 - The actual printing. One bigish loop takes 20 | care of printing all the values in the data space. 21 | Character and numeric data types are dealt with 22 | differently: character data is handled on the spot, 23 | numeric data requires a call to fpt2char(). After each 24 | value (character or numeral) is printed, a test is 25 | performed to see if a line feed is required. For 26 | instance: if pagewidth is exceeded or if the end of 27 | a major block (ie "dimension") is reached. 28 | 29 | fpt_size(), fpt_adjust() and fpt2char are in the ../format 30 | directory. 31 | 32 | -------------------------------------------------------------------------------- /source/print/Makefile: -------------------------------------------------------------------------------- 1 | # Makefile for print 2 | 3 | include ../include/makefile.common 4 | CFLAGS += -I../include 5 | 6 | OBJECTS = print.o ex_hprint.o ex_print.o\ 7 | fp_print.o lt_print.o c_overbar.o print_line.o 8 | 9 | all: Q.o 10 | 11 | Q.o: $(OBJECTS) 12 | $(LD) -r -o Q.o $(OBJECTS) 13 | 14 | $(OBJECTS): ../include/apl.h 15 | 16 | print.o: ../include/format.h 17 | 18 | .c.o: 19 | $(CC) $(CFLAGS) -c $< 20 | 21 | clean: 22 | rm -f *.o 23 | 24 | -------------------------------------------------------------------------------- /source/print/c_overbar.c: -------------------------------------------------------------------------------- 1 | /* c_overbar.c, Copyright (C) 2016, Greg Johnson 2 | * Released under the terms of the GNU GPL v2.0. 3 | * 4 | * This program is distributed in the hope that it will be useful, 5 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 6 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 7 | * GNU General Public License for more details. 8 | */ 9 | #include "apl.h" 10 | #include "char.h" 11 | 12 | char c_overbar(void) { 13 | return ascii_characters ? '`' : C_OVERBAR; 14 | } 15 | -------------------------------------------------------------------------------- /source/print/ex_hprint.c: -------------------------------------------------------------------------------- 1 | /* Copyright U S WEST Advanced Technologies, Inc. 2 | * You may use, copy, modify and sublicense this Software 3 | * subject to the conditions expressed in the file "License". 4 | */ 5 | #include "apl.h" 6 | #include "data.h" 7 | #include "local_print.h" 8 | 9 | void ex_hprint() 10 | { 11 | print(); 12 | pop(); 13 | } 14 | -------------------------------------------------------------------------------- /source/print/ex_print.c: -------------------------------------------------------------------------------- 1 | /* Copyright U S WEST Advanced Technologies, Inc. 2 | * You may use, copy, modify and sublicense this Software 3 | * subject to the conditions expressed in the file "License". 4 | */ 5 | #include "apl.h" 6 | #include "local_print.h" 7 | 8 | int ex_print() 9 | { 10 | if (print()) { /* print() would only return 0 for type NIL */ 11 | putchar('\n'); 12 | column = 0; 13 | } 14 | return (0); 15 | } 16 | -------------------------------------------------------------------------------- /source/print/local_print.h: -------------------------------------------------------------------------------- 1 | /* local_print.h, Copyright (C) 2016, Greg Johnson 2 | * Released under the terms of the GNU GPL v2.0. 3 | * 4 | * This program is distributed in the hope that it will be useful, 5 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 6 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 7 | * GNU General Public License for more details. 8 | */ 9 | #ifndef LOCAL_PRINT_H 10 | #define LOCAL_PRINT_H 11 | 12 | #include "apl.h" 13 | 14 | int print(); 15 | int fp_print(item_t* p); 16 | int lt_print(item_t* p); 17 | 18 | #endif 19 | -------------------------------------------------------------------------------- /source/print/lt_print.c: -------------------------------------------------------------------------------- 1 | /* openAPL, Copyright (C) Branko Bratkovic 1999 2 | * This file is free software and is covered by the GNU General 3 | * Public License. 4 | * 5 | * This program is distributed in the hope that it will be useful, 6 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 7 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. 8 | * 9 | * For more details see the GNU General Public License (GPL) in 10 | * the docs directory. 11 | */ 12 | 13 | #include "apl.h" 14 | #include "format.h" 15 | #include "data.h" 16 | #include "main.h" 17 | 18 | /* Print literals */ 19 | int lt_print(item_t* p) 20 | { 21 | int i, j; 22 | 23 | bidx(p); 24 | 25 | for (i = 1; i < p->size; i++) { 26 | if (intflg) 27 | break; 28 | j = getdat(p); 29 | putAplTouchtypeChar(j); 30 | column++; 31 | if (column >= pagewidth) { 32 | putchar('\n'); 33 | column = 0; 34 | } 35 | 36 | /* has end of dimension been reached? */ 37 | if (i != p->size) { 38 | for (j = p->rank - 2; j >= 0; j--) { 39 | if (i % idx.del[j] == 0) { 40 | putchar('\n'); 41 | column = 0; 42 | } 43 | } 44 | } 45 | } 46 | 47 | j = getdat(p); 48 | putAplTouchtypeChar(j); 49 | column++; 50 | if (column >= pagewidth) { 51 | putchar('\n'); 52 | column = 0; 53 | } 54 | return (1); 55 | } 56 | -------------------------------------------------------------------------------- /source/print/print.c: -------------------------------------------------------------------------------- 1 | /* openAPL, Copyright (C) Branko Bratkovic 1999 2 | * This file is free software and is covered by the GNU General 3 | * Public License. 4 | * 5 | * This program is distributed in the hope that it will be useful, 6 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 7 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. 8 | * 9 | * For more details see the GNU General Public License (GPL) in 10 | * the docs directory. 11 | */ 12 | 13 | #include "apl.h" 14 | #include "utility.h" 15 | #include "format.h" 16 | #include "local_print.h" 17 | 18 | char format_buffer[80]; 19 | 20 | int print() 21 | { 22 | item_t* p; 23 | 24 | p = fetch1(); 25 | 26 | if (p->itemType == NIL) { 27 | return (0); 28 | } 29 | 30 | if (p->size == 0) { 31 | return (1); 32 | } 33 | 34 | switch (p->itemType) { 35 | case DA: 36 | fp_print(p); 37 | break; 38 | 39 | case CH: 40 | lt_print(p); 41 | break; 42 | 43 | default: 44 | error(ERR_botch, "attempt to print unsupported type"); 45 | } 46 | 47 | return (1); 48 | } 49 | -------------------------------------------------------------------------------- /source/print/print_line.c: -------------------------------------------------------------------------------- 1 | /* print_line.c, Copyright (C) 2018, Greg Johnson 2 | * Released under the terms of the GNU GPL v2.0. 3 | * 4 | * This program is distributed in the hope that it will be useful, 5 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 6 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 7 | * GNU General Public License for more details. 8 | */ 9 | #include 10 | #include "main.h" 11 | 12 | void printLine(char *line) { 13 | int i; 14 | int len = strlen(line); 15 | 16 | for (i = 0; i < len; ++i) { 17 | putAplTouchtypeChar(line[i]); 18 | } 19 | } 20 | -------------------------------------------------------------------------------- /source/quad_func/Makefile: -------------------------------------------------------------------------------- 1 | # Makefile for quad_func (quad functions) 2 | 3 | include ../include/makefile.common 4 | CFLAGS += -I../include 5 | 6 | OBJECTS = eval_qlx.o ex_crp.o ex_float.o ex_open.o ex_seek.o iofname.o \ 7 | ex_ap.o ex_dup.o ex_fork.o ex_pipe.o ex_signl.o \ 8 | ex_chdir.o ex_exec.o ex_kill.o ex_rd.o ex_unlink.o \ 9 | ex_close.o ex_exit.o ex_nc.o ex_read.o ex_wait.o \ 10 | ex_create.o ex_fdef.o ex_nl.o ex_run.o ex_write.o ex_ex.o 11 | 12 | all: Q.o 13 | 14 | Q.o: $(OBJECTS) 15 | $(LD) -r -o Q.o $(OBJECTS) 16 | 17 | $(OBJECTS): ../include/apl.h 18 | 19 | # Things that depend on characters 20 | eval_qlx.o ex_nc.o ex_run.o ex_crp.o ex_exec.o ex_fdef.o \ 21 | ex_nl.o ex_rd.o ex_seek.o ex_write.o : ../include/char.h 22 | 23 | .c.o: 24 | $(CC) $(CFLAGS) -c $< 25 | 26 | clean: 27 | rm -f $(OBJECTS) core 28 | 29 | -------------------------------------------------------------------------------- /source/quad_func/eval_qlx.c: -------------------------------------------------------------------------------- 1 | /* Copyright U S WEST Advanced Technologies, Inc. 2 | * You may use, copy, modify and sublicense this Software 3 | * subject to the conditions expressed in the file "License". 4 | */ 5 | 6 | #include "apl.h" 7 | #include "data.h" 8 | #include "char.h" 9 | #include "print.h" 10 | #include "mixed_monadic.h" 11 | 12 | /* 13 | * check for latent expr quad LX and evaluate it if found 14 | */ 15 | 16 | void eval_qlx() 17 | { 18 | SymTabEntry* n; 19 | item_t* p; 20 | 21 | if ((n = nlook(S_QUAD "lx")) && n->itemp->itemType == CH && n->itemp->size) { 22 | *expr_stack_ptr++ = dupdat(n->itemp); 23 | sandbox = 1; 24 | ex_execute(); 25 | sandbox = sandboxflg; 26 | p = expr_stack_ptr[-1]; 27 | if (p->itemType != EL && p->itemType != NIL) 28 | ex_print(); 29 | pop(); 30 | } 31 | } 32 | -------------------------------------------------------------------------------- /source/quad_func/ex_ap.c: -------------------------------------------------------------------------------- 1 | /* Copyright U S WEST Advanced Technologies, Inc. 2 | * You may use, copy, modify and sublicense this Software 3 | * subject to the conditions expressed in the file "License". 4 | */ 5 | #include 6 | 7 | #include "apl.h" 8 | #include "data.h" 9 | #include "utility.h" 10 | #include "work_space.h" 11 | 12 | void ex_ap() 13 | { 14 | int fd; 15 | item_t* p; 16 | 17 | SECURITY_CHECK; 18 | fd = topfix(); 19 | p = fetch1(); 20 | lseek(fd, 0L, SEEK_END); 21 | fappend(fd, p); 22 | if (p->rank == 1) 23 | writeErrorOnFailure(fd, "\n", 1); 24 | pop(); 25 | *expr_stack_ptr++ = newdat(DA, 1, 0); 26 | } 27 | -------------------------------------------------------------------------------- /source/quad_func/ex_chdir.c: -------------------------------------------------------------------------------- 1 | /* Copyright U S WEST Advanced Technologies, Inc. 2 | * You may use, copy, modify and sublicense this Software 3 | * subject to the conditions expressed in the file "License". 4 | */ 5 | #include 6 | 7 | #include "apl.h" 8 | #include "utility.h" 9 | 10 | char* iofname(); 11 | 12 | void ex_chdir() 13 | { 14 | SECURITY_CHECK; 15 | iodone(chdir(iofname())); 16 | } 17 | -------------------------------------------------------------------------------- /source/quad_func/ex_close.c: -------------------------------------------------------------------------------- 1 | /* Copyright U S WEST Advanced Technologies, Inc. 2 | * You may use, copy, modify and sublicense this Software 3 | * subject to the conditions expressed in the file "License". 4 | */ 5 | #include 6 | 7 | #include "apl.h" 8 | #include "utility.h" 9 | 10 | void ex_close() 11 | { 12 | SECURITY_CHECK; 13 | iodone(close(topfix())); 14 | } 15 | -------------------------------------------------------------------------------- /source/quad_func/ex_create.c: -------------------------------------------------------------------------------- 1 | /* Copyright U S WEST Advanced Technologies, Inc. 2 | * You may use, copy, modify and sublicense this Software 3 | * subject to the conditions expressed in the file "License". 4 | */ 5 | #include 6 | 7 | #include "apl.h" 8 | #include "utility.h" 9 | 10 | char* iofname(); 11 | 12 | void ex_creat() 13 | { 14 | int m; 15 | 16 | SECURITY_CHECK; 17 | m = topfix(); 18 | iodone(creat(iofname(), m)); 19 | } 20 | -------------------------------------------------------------------------------- /source/quad_func/ex_dup.c: -------------------------------------------------------------------------------- 1 | /* Copyright U S WEST Advanced Technologies, Inc. 2 | * You may use, copy, modify and sublicense this Software 3 | * subject to the conditions expressed in the file "License". 4 | */ 5 | #include 6 | 7 | #include "apl.h" 8 | #include "utility.h" 9 | 10 | void ex_dup() 11 | { 12 | SECURITY_CHECK; 13 | iodone(dup(topfix())); 14 | } 15 | -------------------------------------------------------------------------------- /source/quad_func/ex_ex.c: -------------------------------------------------------------------------------- 1 | #include "apl.h" 2 | #include "data.h" 3 | #include "utility.h" 4 | #include "char.h" 5 | 6 | void ex_ex(void) 7 | { 8 | SymTabEntry* np; 9 | item_t *p, *ip; 10 | int i, nlen; 11 | int j, n; 12 | char buf[40]; 13 | 14 | p = fetch1(); 15 | if (p->itemType != CH) 16 | error(ERR_domain, ""); 17 | if (p->rank > 2) 18 | error(ERR_rank, ""); 19 | if (p->rank < 2) { 20 | n = 1; 21 | nlen = p->size; 22 | } 23 | else { 24 | n = p->dim[0]; 25 | nlen = p->dim[1]; 26 | } 27 | if (nlen >= 40) 28 | error(ERR_length, ""); 29 | ip = newdat(DA, 1, n); 30 | 31 | for (j = 0; j < n; j++) { 32 | copy(CH, ((char*)p->datap) + nlen * j, buf, nlen); 33 | buf[nlen] = 0; 34 | for (i = nlen - 1; buf[i] == ' '; i--) 35 | buf[i] = 0; 36 | np = nlook(buf); 37 | i = 0; 38 | if (np != 0) { 39 | if ( np->entryUse == MF 40 | || np->entryUse == NF 41 | || np->entryUse == DF 42 | || np->entryUse == DA 43 | || np->entryUse == CH 44 | || np->entryUse == LV) 45 | { 46 | erase(np); 47 | i = 1; 48 | } 49 | } 50 | ip->datap[j] = i; 51 | } 52 | pop(); 53 | *expr_stack_ptr++ = ip; 54 | } 55 | -------------------------------------------------------------------------------- /source/quad_func/ex_exec.c: -------------------------------------------------------------------------------- 1 | /* Copyright U S WEST Advanced Technologies, Inc. 2 | * You may use, copy, modify and sublicense this Software 3 | * subject to the conditions expressed in the file "License". 4 | */ 5 | #include 6 | 7 | #include "apl.h" 8 | #include "data.h" 9 | #include "utility.h" 10 | #include "char.h" 11 | 12 | #define MAXP 20 13 | 14 | void ex_exec() 15 | { 16 | item_t* p; 17 | int i, j; 18 | char *cp, *argv[MAXP + 1]; 19 | 20 | SECURITY_CHECK; 21 | p = fetch1(); 22 | if (!p->rank || p->rank > 2) 23 | error(ERR_rank, ""); 24 | if (p->size > 500) 25 | error(ERR_length, ""); 26 | if (p->itemType != CH) 27 | error(ERR_domain, ""); 28 | if (p->rank == 2) { 29 | if (p->dim[0] > MAXP) 30 | error(ERR_length, ""); 31 | cp = (char*)(p->datap); 32 | for (i = 0; i < p->dim[0]; i++) 33 | argv[i] = cp + i * p->dim[1]; 34 | argv[p->dim[0]] = 0; 35 | } 36 | else { 37 | cp = (char*)(p->datap); 38 | for (i = j = 0; i < MAXP && cp < (char*)(p->datap) + p->size; cp++) { 39 | if (!*cp) 40 | j = 0; 41 | else if (!j) { 42 | j = 1; 43 | argv[i++] = (char*)cp; 44 | } 45 | } 46 | if (i == MAXP || *--cp) 47 | error(ERR, "exec - panic"); 48 | argv[i] = 0; 49 | } 50 | execv(argv[0], &argv[1]); 51 | pop(); 52 | p = newdat(DA, 0, 0); 53 | *expr_stack_ptr++ = p; 54 | } 55 | -------------------------------------------------------------------------------- /source/quad_func/ex_exit.c: -------------------------------------------------------------------------------- 1 | /* Copyright U S WEST Advanced Technologies, Inc. 2 | * You may use, copy, modify and sublicense this Software 3 | * subject to the conditions expressed in the file "License". 4 | */ 5 | 6 | #include "apl.h" 7 | #include "utility.h" 8 | #include "main.h" 9 | 10 | void ex_exit() 11 | { 12 | SECURITY_CHECK; 13 | Exit(topfix()); 14 | } 15 | -------------------------------------------------------------------------------- /source/quad_func/ex_float.c: -------------------------------------------------------------------------------- 1 | /* Copyright U S WEST Advanced Technologies, Inc. 2 | * You may use, copy, modify and sublicense this Software 3 | * subject to the conditions expressed in the file "License". 4 | */ 5 | 6 | #include "apl.h" 7 | #include "utility.h" 8 | 9 | void ex_float() 10 | { 11 | 12 | /* Convert characters into either double-precision (apl) 13 | * or single-precision (apl2) format. (Involves only 14 | * changing the data type and size declarations. 15 | */ 16 | 17 | item_t* p; 18 | 19 | p = fetch1(); /* Get variable descriptor */ 20 | 21 | if (p->itemType != CH) 22 | error(ERR_domain, ""); /* Must be characters */ 23 | 24 | if (p->rank == 0 /* Scalar */ 25 | || p->dim[(p->rank) - 1] % sizeof datum) /* Bad size */ 26 | error(ERR_length, ""); 27 | 28 | p->dim[p->rank - 1] /= sizeof datum; /* Reduce dimensions */ 29 | p->size /= sizeof datum; /* Reduce size */ 30 | p->itemType = DA; /* Change data type */ 31 | } 32 | -------------------------------------------------------------------------------- /source/quad_func/ex_fork.c: -------------------------------------------------------------------------------- 1 | /* Copyright U S WEST Advanced Technologies, Inc. 2 | * You may use, copy, modify and sublicense this Software 3 | * subject to the conditions expressed in the file "License". 4 | */ 5 | #include 6 | 7 | #include "apl.h" 8 | #include "data.h" 9 | #include "utility.h" 10 | 11 | void ex_fork() 12 | { 13 | int pid; 14 | 15 | SECURITY_CHECK; 16 | if ((pid = fork()) == -1) 17 | error(ERR, "could not fork"); 18 | pop(); 19 | iodone(pid); 20 | } 21 | -------------------------------------------------------------------------------- /source/quad_func/ex_kill.c: -------------------------------------------------------------------------------- 1 | /* Copyright U S WEST Advanced Technologies, Inc. 2 | * You may use, copy, modify and sublicense this Software 3 | * subject to the conditions expressed in the file "License". 4 | */ 5 | #include 6 | 7 | #include "apl.h" 8 | #include "utility.h" 9 | #include "data.h" 10 | 11 | void ex_kill() 12 | { 13 | int pid, signo; 14 | 15 | SECURITY_CHECK; 16 | pid = topfix(); 17 | signo = topfix(); 18 | kill(pid, signo); 19 | *expr_stack_ptr++ = newdat(DA, 1, 0); 20 | } 21 | -------------------------------------------------------------------------------- /source/quad_func/ex_nc.c: -------------------------------------------------------------------------------- 1 | /* Copyright U S WEST Advanced Technologies, Inc. 2 | * You may use, copy, modify and sublicense this Software 3 | * subject to the conditions expressed in the file "License". 4 | */ 5 | 6 | #include "apl.h" 7 | #include "data.h" 8 | #include "utility.h" 9 | #include "char.h" 10 | 11 | void ex_nc() 12 | { 13 | SymTabEntry* np; 14 | item_t* p; 15 | int i; 16 | char buf[40]; 17 | 18 | p = fetch1(); 19 | if (p->itemType != CH) 20 | error(ERR_domain, ""); 21 | if (p->size >= 40 || p->rank > 1) 22 | error(ERR_rank, ""); 23 | copy(CH, (char*)p->datap, (char*)buf, p->size); 24 | buf[p->size] = 0; 25 | np = nlook(buf); 26 | i = 0; 27 | if (np != 0) { 28 | switch (np->entryUse) { 29 | case 0: 30 | i = 0; 31 | break; 32 | case MF: 33 | case NF: 34 | case DF: 35 | i = 3; 36 | break; 37 | case DA: 38 | case CH: 39 | case LV: 40 | i = 2; 41 | break; 42 | default: 43 | printf("unknown " S_QUAD_ASCII " nc type = %d\n", np->entryUse); 44 | i = 4; 45 | } 46 | } 47 | p = newdat(DA, 0, 1); 48 | p->datap[0] = i; 49 | pop(); 50 | *expr_stack_ptr++ = p; 51 | } 52 | -------------------------------------------------------------------------------- /source/quad_func/ex_open.c: -------------------------------------------------------------------------------- 1 | /* Copyright U S WEST Advanced Technologies, Inc. 2 | * You may use, copy, modify and sublicense this Software 3 | * subject to the conditions expressed in the file "License". 4 | */ 5 | #include 6 | 7 | #include "apl.h" 8 | #include "utility.h" 9 | 10 | char* iofname(); 11 | 12 | void ex_open() 13 | { 14 | int m; 15 | 16 | m = topfix(); 17 | SECURITY_CHECK; 18 | iodone(open(iofname(), m)); 19 | } 20 | -------------------------------------------------------------------------------- /source/quad_func/ex_pipe.c: -------------------------------------------------------------------------------- 1 | /* Copyright U S WEST Advanced Technologies, Inc. 2 | * You may use, copy, modify and sublicense this Software 3 | * subject to the conditions expressed in the file "License". 4 | */ 5 | #include 6 | 7 | #include "apl.h" 8 | #include "data.h" 9 | #include "utility.h" 10 | 11 | void ex_pipe() 12 | { 13 | item_t* p; 14 | int pp[2]; 15 | 16 | SECURITY_CHECK; 17 | if (pipe(pp) == -1) 18 | p = newdat(DA, 1, 0); 19 | else { 20 | p = newdat(DA, 1, 2); 21 | p->datap[0] = pp[0]; 22 | p->datap[1] = pp[1]; 23 | } 24 | pop(); 25 | *expr_stack_ptr++ = p; 26 | } 27 | -------------------------------------------------------------------------------- /source/quad_func/ex_rd.c: -------------------------------------------------------------------------------- 1 | /* Copyright U S WEST Advanced Technologies, Inc. 2 | * You may use, copy, modify and sublicense this Software 3 | * subject to the conditions expressed in the file "License". 4 | */ 5 | #include 6 | 7 | #include "apl.h" 8 | #include "data.h" 9 | #include "utility.h" 10 | #include "char.h" 11 | 12 | void ex_rd() 13 | { 14 | /* note: 15 | * an empty line is converted to NULL. 16 | * no '\n' chars are returned. 17 | */ 18 | char buf[200]; 19 | item_t* p; 20 | int fd, i; 21 | 22 | SECURITY_CHECK; 23 | fd = topfix(); 24 | i = 0; 25 | while ((read(fd, &buf[i], 1) == 1) && i < 200 && buf[i] != '\n') 26 | i++; 27 | if (i == 200) 28 | error(ERR_limit, "input buffer overflow"); 29 | if (i > 0) { 30 | p = newdat(CH, 1, i); 31 | copy(CH, (char*)buf, (char*)p->datap, i); 32 | } 33 | else 34 | p = newdat(CH, 1, 0); 35 | *expr_stack_ptr++ = p; 36 | } 37 | -------------------------------------------------------------------------------- /source/quad_func/ex_read.c: -------------------------------------------------------------------------------- 1 | /* Copyright U S WEST Advanced Technologies, Inc. 2 | * You may use, copy, modify and sublicense this Software 3 | * subject to the conditions expressed in the file "License". 4 | */ 5 | #include 6 | 7 | #include "apl.h" 8 | #include "data.h" 9 | #include "utility.h" 10 | #include "memory.h" 11 | 12 | void ex_read() 13 | { 14 | item_t *p, *q; 15 | int fd, nb, c; 16 | 17 | SECURITY_CHECK; 18 | fd = topfix(); 19 | nb = topfix(); 20 | p = newdat(CH, 1, nb); 21 | c = read(fd, p->datap, nb); 22 | if (c != nb) { 23 | q = p; 24 | if (c <= 0) 25 | p = newdat(CH, 1, 0); 26 | else { 27 | p = newdat(CH, 1, c); 28 | copy(CH, (char*)q->datap, (char*)p->datap, c); 29 | } 30 | aplfree(q); 31 | } 32 | *expr_stack_ptr++ = p; 33 | } 34 | -------------------------------------------------------------------------------- /source/quad_func/ex_run.c: -------------------------------------------------------------------------------- 1 | /* Copyright U S WEST Advanced Technologies, Inc. 2 | * You may use, copy, modify and sublicense this Software 3 | * subject to the conditions expressed in the file "License". 4 | */ 5 | #include 6 | 7 | #include "apl.h" 8 | #include "data.h" 9 | #include "utility.h" 10 | #include "char.h" 11 | 12 | void ex_run() 13 | { 14 | item_t* p; 15 | char ebuf[100]; 16 | int val; 17 | 18 | SECURITY_CHECK; 19 | p = fetch1(); 20 | if (p->itemType != CH) 21 | error(ERR_domain, ""); 22 | if (p->rank != 1) 23 | error(ERR_rank, ""); 24 | copy(CH, (char*)p->datap, (char*)ebuf, p->size); 25 | ebuf[p->size] = 0; 26 | val = system(ebuf); 27 | p = newdat(DA, 0, 1); 28 | p->datap[0] = (data)val; 29 | pop(); 30 | *expr_stack_ptr++ = p; 31 | } 32 | -------------------------------------------------------------------------------- /source/quad_func/ex_seek.c: -------------------------------------------------------------------------------- 1 | /* Copyright U S WEST Advanced Technologies, Inc. 2 | * You may use, copy, modify and sublicense this Software 3 | * subject to the conditions expressed in the file "License". 4 | */ 5 | #include 6 | 7 | #include "apl.h" 8 | #include "data.h" 9 | #include "utility.h" 10 | #include "char.h" 11 | 12 | void ex_seek() 13 | { 14 | item_t* p; 15 | int k1, k3; 16 | long k2; 17 | 18 | SECURITY_CHECK; 19 | p = fetch1(); 20 | if (p->itemType != DA) 21 | error(ERR_domain, ""); 22 | if (p->rank != 1) 23 | error(ERR_rank, ""); 24 | if (p->size != 3) 25 | error(ERR_length, ""); 26 | k1 = p->datap[0]; 27 | k2 = p->datap[1]; 28 | k3 = p->datap[2]; 29 | k1 = lseek(k1, k2, k3); 30 | pop(); 31 | iodone(k1); 32 | } 33 | -------------------------------------------------------------------------------- /source/quad_func/ex_signl.c: -------------------------------------------------------------------------------- 1 | /* Copyright U S WEST Advanced Technologies, Inc. 2 | * You may use, copy, modify and sublicense this Software 3 | * subject to the conditions expressed in the file "License". 4 | */ 5 | #include 6 | typedef void (sighandler_t)(int); 7 | 8 | #include "apl.h" 9 | #include "utility.h" 10 | 11 | void ex_signl() 12 | { 13 | int i, j; 14 | 15 | i = topfix(); 16 | j = topfix(); 17 | 18 | if (j == 0) { 19 | iodone(signal(i, SIG_DFL) == SIG_ERR ? -1 : 0); 20 | 21 | } else if (j == 1) { 22 | iodone(signal(i, SIG_IGN) == SIG_ERR ? -1 : 0); 23 | 24 | } else { 25 | error(ERR_domain, "signal"); 26 | } 27 | } 28 | -------------------------------------------------------------------------------- /source/quad_func/ex_unlink.c: -------------------------------------------------------------------------------- 1 | /* Copyright U S WEST Advanced Technologies, Inc. 2 | * You may use, copy, modify and sublicense this Software 3 | * subject to the conditions expressed in the file "License". 4 | */ 5 | #include 6 | 7 | #include "apl.h" 8 | #include "utility.h" 9 | 10 | char* iofname(); 11 | 12 | void ex_unlink() 13 | { 14 | SECURITY_CHECK; 15 | iodone(unlink(iofname())); 16 | } 17 | -------------------------------------------------------------------------------- /source/quad_func/ex_wait.c: -------------------------------------------------------------------------------- 1 | /* Copyright U S WEST Advanced Technologies, Inc. 2 | * You may use, copy, modify and sublicense this Software 3 | * subject to the conditions expressed in the file "License". 4 | */ 5 | #include 6 | #include 7 | 8 | #include "apl.h" 9 | #include "data.h" 10 | #include "utility.h" 11 | 12 | void ex_wait() 13 | { 14 | item_t* p; 15 | void (*sig)(int); 16 | pid_t pid; 17 | int s; 18 | 19 | SECURITY_CHECK; 20 | sig = signal(SIGINT, SIG_IGN); 21 | pid = wait(&s); 22 | signal(SIGINT, sig); 23 | p = newdat(DA, 1, 3); 24 | p->datap[0] = pid; 25 | p->datap[1] = s & 0377; 26 | p->datap[2] = (s >> 8) & 0377; 27 | pop(); /* dummy arg */ 28 | *expr_stack_ptr++ = p; 29 | } 30 | -------------------------------------------------------------------------------- /source/quad_func/ex_write.c: -------------------------------------------------------------------------------- 1 | /* Copyright U S WEST Advanced Technologies, Inc. 2 | * You may use, copy, modify and sublicense this Software 3 | * subject to the conditions expressed in the file "License". 4 | */ 5 | #include 6 | 7 | #include "apl.h" 8 | #include "data.h" 9 | #include "utility.h" 10 | #include "char.h" 11 | 12 | void ex_write() 13 | { 14 | int fd, m; 15 | item_t* p; 16 | int mult; /* Multiplier (data size) */ 17 | 18 | SECURITY_CHECK; 19 | fd = topfix(); 20 | p = fetch1(); 21 | if (p->itemType != CH && p->itemType != DA) 22 | error(ERR_domain, ""); 23 | mult = p->itemType == CH ? 1 : sizeof datum; 24 | m = write(fd, p->datap, p->size * mult) / mult; 25 | pop(); 26 | iodone(m); 27 | } 28 | -------------------------------------------------------------------------------- /source/quad_func/iofname.c: -------------------------------------------------------------------------------- 1 | /* Copyright U S WEST Advanced Technologies, Inc. 2 | * You may use, copy, modify and sublicense this Software 3 | * subject to the conditions expressed in the file "License". 4 | */ 5 | 6 | #include "apl.h" 7 | #include "data.h" 8 | #include "utility.h" 9 | static char b[200]; 10 | 11 | char* iofname(int m) 12 | { 13 | item_t* p; 14 | 15 | p = fetch1(); 16 | if (p->itemType != CH || p->rank > 1) 17 | error(ERR_implicit, "file name"); 18 | copy(CH, (char*)p->datap, (char*)b, p->size); 19 | b[p->size] = 0; 20 | pop(); 21 | return (b); 22 | } 23 | -------------------------------------------------------------------------------- /source/quad_var/Makefile: -------------------------------------------------------------------------------- 1 | # Makefile for quad_var (quad variables) 2 | 3 | include ../include/makefile.common 4 | CFLAGS += -I../include 5 | 6 | OBJECTS = ex_quad.o ex_qquad.o \ 7 | ex_qav.o ex_qct.o ex_qio.o ex_qlx.o ex_qpp.o ex_qpw.o \ 8 | ex_qts.o ex_qai.o ex_qargv.o 9 | 10 | all: Q.o 11 | 12 | Q.o: $(OBJECTS) 13 | $(LD) -r -o Q.o $(OBJECTS) 14 | 15 | $(OBJECTS): ../include/apl.h 16 | 17 | # Things that depend on characters 18 | ex_qav.o ex_qlx.o ex_qpp.o ex_qpw.o ex_quad.o : ../include/char.h 19 | 20 | .c.o: 21 | $(CC) $(CFLAGS) -c $< 22 | 23 | clean: 24 | rm -f $(OBJECTS) core 25 | 26 | -------------------------------------------------------------------------------- /source/quad_var/ex_qai.c: -------------------------------------------------------------------------------- 1 | /* openAPL, Copyright (C) Branko Bratkovic 1998 2 | * This file is free software and is covered by the GNU General 3 | * Public License. 4 | * 5 | * This program is distributed in the hope that it will be useful, 6 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 7 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. 8 | * 9 | * For more details see the GNU General Public License (GPL) in 10 | * the docs directory. 11 | */ 12 | 13 | #include 14 | #include 15 | #include 16 | #include 17 | #include "apl.h" 18 | #include "utility.h" 19 | #include "data.h" 20 | 21 | item_t* ex_qai(io) int io; /* 0 = source, 1 = sink */ 22 | { 23 | struct tms t; 24 | item_t* p; 25 | long tv; 26 | 27 | if (io == 0) { 28 | time(&tv); 29 | times(&t); 30 | p = newdat(DA, 1, 4); 31 | p->datap[0] = (data)geteuid(); 32 | p->datap[1] = t.tms_utime + t.tms_cutime; 33 | p->datap[3] = tv - startTime; 34 | p->datap[2] = t.tms_stime + t.tms_cstime; 35 | return (p); 36 | } 37 | else { 38 | error(ERR_implicit, "cannot change accounting info"); 39 | return (0); 40 | }; 41 | } 42 | -------------------------------------------------------------------------------- /source/quad_var/ex_qargv.c: -------------------------------------------------------------------------------- 1 | /* openAPL, Copyright (C) Branko Bratkovic 1998 2 | * This file is free software and is covered by the GNU General 3 | * Public License. 4 | * 5 | * This program is distributed in the hope that it will be useful, 6 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 7 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. 8 | * 9 | * For more details see the GNU General Public License (GPL) in 10 | * the docs directory. 11 | */ 12 | 13 | #include 14 | #include "apl.h" 15 | #include "utility.h" 16 | #include "data.h" 17 | #include "char.h" 18 | #include "main.h" 19 | 20 | item_t* ex_qargv(io) int io; /* 0 = source, 1 = sink */ 21 | { 22 | item_t* p; 23 | int i; 24 | int row, col; 25 | char* n; 26 | 27 | if (io == 0) { 28 | int max_len = 0; 29 | for (i = gbl_optind; i < gbl_argc; ++i) { 30 | int len = strlen(gbl_argv[i]); 31 | if (max_len < len) max_len = len; 32 | } 33 | 34 | p = newdat(CH, 2, (gbl_argc - gbl_optind) * max_len); 35 | n = (char*)p->datap; 36 | p->dim[0] = gbl_argc - gbl_optind; 37 | p->dim[1] = max_len; 38 | 39 | for (row = 0; row < gbl_argc - gbl_optind; ++row) { 40 | int argv_ind = row + gbl_optind; 41 | int len = strlen(gbl_argv[argv_ind]); 42 | for (col = 0; col < len; ++col) { 43 | *n++ = gbl_argv[argv_ind][col]; 44 | } 45 | for (col = len; col < max_len; ++col) { 46 | *n++ = ' '; 47 | } 48 | } 49 | return (p); 50 | } 51 | else { 52 | error(ERR_implicit, "cannot change " S_QUAD_ASCII "argv"); 53 | }; 54 | return (0); 55 | } 56 | -------------------------------------------------------------------------------- /source/quad_var/ex_qav.c: -------------------------------------------------------------------------------- 1 | /* openAPL, Copyright (C) Branko Bratkovic 1998 2 | * This file is free software and is covered by the GNU General 3 | * Public License. 4 | * 5 | * This program is distributed in the hope that it will be useful, 6 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 7 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. 8 | * 9 | * For more details see the GNU General Public License (GPL) in 10 | * the docs directory. 11 | */ 12 | 13 | #include 14 | #include "apl.h" 15 | #include "utility.h" 16 | #include "data.h" 17 | #include "char.h" 18 | 19 | item_t* ex_qav(io) int io; /* 0 = source, 1 = sink */ 20 | { 21 | item_t* p; 22 | int i; 23 | char* n; 24 | 25 | if (io == 0) { 26 | p = newdat(CH, 1, 256); 27 | n = (char*)p->datap; 28 | for (i = 0; i < p->size; i++) { 29 | *n = i; 30 | n++; 31 | } 32 | return (p); 33 | } 34 | else { 35 | error(ERR_implicit, "cannot change " S_QUAD_ASCII "av"); 36 | }; 37 | return (0); 38 | } 39 | -------------------------------------------------------------------------------- /source/quad_var/ex_qct.c: -------------------------------------------------------------------------------- 1 | /* openAPL, Copyright (C) Branko Bratkovic 1998 2 | * This file is free software and is covered by the GNU General 3 | * Public License. 4 | * 5 | * This program is distributed in the hope that it will be useful, 6 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 7 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. 8 | * 9 | * For more details see the GNU General Public License (GPL) in 10 | * the docs directory. 11 | */ 12 | 13 | #include 14 | #include "apl.h" 15 | #include "data.h" 16 | #include "utility.h" 17 | #include "char.h" 18 | 19 | item_t* ex_qct(io) int io; /* 0 = source, 1 = sink */ 20 | { 21 | item_t* p; 22 | data f; 23 | 24 | if (io == 0) { 25 | p = newdat(DA, 0, 1); 26 | p->datap[0] = tolerance; 27 | return (p); 28 | } 29 | else { 30 | pop(); 31 | p = fetch1(); 32 | 33 | if (p->itemType != DA) 34 | error(ERR_domain, "assign value not numeric"); 35 | 36 | if (p->rank != 0) 37 | error(ERR_rank, "assign value not scalar"); 38 | 39 | f = p->datap[0]; 40 | if (f < 0) 41 | f = -f; 42 | tolerance = f; 43 | expr_stack_ptr[-1] = (item_t*)p; 44 | return (0); 45 | }; 46 | } 47 | -------------------------------------------------------------------------------- /source/quad_var/ex_qio.c: -------------------------------------------------------------------------------- 1 | /* openAPL, Copyright (C) Branko Bratkovic 1998 2 | * This file is free software and is covered by the GNU General 3 | * Public License. 4 | * 5 | * This program is distributed in the hope that it will be useful, 6 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 7 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. 8 | * 9 | * For more details see the GNU General Public License (GPL) in 10 | * the docs directory. 11 | */ 12 | 13 | /* Changed 26.9.1999 by tyl */ 14 | 15 | #include 16 | #include "apl.h" 17 | #include "data.h" 18 | #include "utility.h" 19 | 20 | item_t* ex_qio(io) int io; /* 0 = source, 1 = sink */ 21 | { 22 | item_t* p; 23 | int i; 24 | 25 | if (io == 0) { 26 | p = newdat(DA, 0, 1); 27 | p->datap[0] = iorigin; 28 | return (p); 29 | } 30 | else { 31 | pop(); 32 | p = fetch1(); 33 | 34 | if (p->itemType != DA) 35 | error(ERR_domain, "assign value not numeric"); 36 | 37 | if (p->rank != 0) 38 | error(ERR_rank, "assign value not scalar"); 39 | 40 | i = fix(p->datap[0]); 41 | if (i == 0 || i == 1) 42 | iorigin = (data)i; 43 | else 44 | error(ERR_domain, "assign value not 0 or 1"); 45 | expr_stack_ptr[-1] = (item_t*)p; 46 | return (0); 47 | }; 48 | } 49 | -------------------------------------------------------------------------------- /source/quad_var/ex_qlx.c: -------------------------------------------------------------------------------- 1 | /* openAPL, Copyright (C) Branko Bratkovic 1998 2 | * This file is free software and is covered by the GNU General 3 | * Public License. 4 | * 5 | * This program is distributed in the hope that it will be useful, 6 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 7 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. 8 | * 9 | * For more details see the GNU General Public License (GPL) in 10 | * the docs directory. 11 | */ 12 | 13 | #include 14 | #include "apl.h" 15 | #include "data.h" 16 | #include "char.h" 17 | #include "memory.h" 18 | 19 | // Llx; latent expression. Execute this string when a 20 | // workspace is loaded. 21 | // Example: Llx { '''Hello. Welcome to this workspace.''' 22 | // 23 | item_t* ex_qlx(io) int io; /* 0 = source, 1 = sink */ 24 | { 25 | item_t *p, *q; 26 | SymTabEntry* n; 27 | 28 | if (io == 0) { 29 | n = nlook(S_QUAD "lx"); 30 | if (n) { 31 | q = n->itemp; 32 | p = dupdat(q); 33 | copy(q->itemType, (char*)q->datap, (char*)p->datap, q->size); 34 | } 35 | else 36 | p = newdat(CH, 1, 0); 37 | return (p); 38 | } 39 | else { 40 | 41 | pop(); 42 | n = nlook(S_QUAD "lx"); 43 | if (n == 0) { /* allocate new name: */ 44 | //for(n=symbolTable; n->namep; n++) ; 45 | char name[4] = S_QUAD "lx"; 46 | n = symtabInsert(name); 47 | n->itemType = LV; 48 | n->entryUse = 0; 49 | n->itemp = newdat(CH, 0, 0); 50 | } 51 | q = fetch1(); 52 | erase(n); 53 | n->entryUse = DA; 54 | n->itemp = q; 55 | expr_stack_ptr[-1] = (item_t*)n; 56 | 57 | return (0); 58 | }; 59 | } 60 | -------------------------------------------------------------------------------- /source/quad_var/ex_qpp.c: -------------------------------------------------------------------------------- 1 | /* openAPL, Copyright (C) Branko Bratkovic 1998 2 | * This file is free software and is covered by the GNU General 3 | * Public License. 4 | * 5 | * This program is distributed in the hope that it will be useful, 6 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 7 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. 8 | * 9 | * For more details see the GNU General Public License (GPL) in 10 | * the docs directory. 11 | */ 12 | 13 | #include 14 | #include "apl.h" 15 | #include "data.h" 16 | #include "utility.h" 17 | #include "char.h" 18 | 19 | void outputPrintP() { 20 | printf("digits %d\n", PrintP); 21 | } 22 | 23 | void updatePrintP(item_t *p) { 24 | int i; 25 | 26 | if (p->itemType != DA) 27 | error(ERR_domain, "assign value not numeric"); 28 | if (p->rank != 0) 29 | error(ERR_rank, "assign value not scalar"); 30 | i = p->datap[0]; 31 | if (i < 1 || i > 20) 32 | error(ERR_limit, S_QUAD_ASCII "pp range is 1 to 20"); 33 | PrintP = i; 34 | } 35 | 36 | item_t* ex_qpp(io) int io; /* 0 = source, 1 = sink */ 37 | { 38 | item_t* p; 39 | 40 | if (io == 0) { 41 | p = newdat(DA, 0, 1); 42 | p->datap[0] = PrintP; 43 | return (p); 44 | } 45 | else { 46 | pop(); 47 | p = fetch1(); 48 | updatePrintP(p); 49 | expr_stack_ptr[-1] = (item_t*)p; 50 | return (0); 51 | }; 52 | } 53 | -------------------------------------------------------------------------------- /source/quad_var/ex_qpw.c: -------------------------------------------------------------------------------- 1 | /* openAPL, Copyright (C) Branko Bratkovic 1998 2 | * This file is free software and is covered by the GNU General 3 | * Public License. 4 | * 5 | * This program is distributed in the hope that it will be useful, 6 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 7 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. 8 | * 9 | * For more details see the GNU General Public License (GPL) in 10 | * the docs directory. 11 | */ 12 | 13 | #include 14 | #include "apl.h" 15 | #include "data.h" 16 | #include "utility.h" 17 | #include "char.h" 18 | 19 | void outputPageWidth() { 20 | printf("width %d\n", pagewidth); 21 | } 22 | 23 | void updatePageWidth(item_t *p) { 24 | int i; 25 | 26 | if (p->itemType != DA) 27 | error(ERR_domain, "assign value not numeric"); 28 | if (p->rank != 0) 29 | error(ERR_rank, "assign value not scalar"); 30 | i = p->datap[0]; 31 | if (i < 10 || i > 132) 32 | error(ERR_limit, "width range is 10 to 132"); 33 | pagewidth = i; 34 | } 35 | 36 | item_t* ex_qpw(io) int io; /* 0 = source, 1 = sink */ 37 | { 38 | item_t* p; 39 | int i; 40 | 41 | if (io == 0) { 42 | p = newdat(DA, 0, 1); 43 | p->datap[0] = pagewidth; 44 | return (p); 45 | } 46 | else { 47 | pop(); 48 | p = fetch1(); 49 | if (p->itemType != DA) 50 | error(ERR_domain, "assign value not numeric"); 51 | if (p->rank != 0) 52 | error(ERR_rank, "assign value not scalar"); 53 | i = p->datap[0]; 54 | if (i < 10 || i > 132) 55 | error(ERR_limit, S_QUAD_ASCII "pw range is 20 to 132"); 56 | pagewidth = i; 57 | expr_stack_ptr[-1] = (item_t*)p; 58 | return (0); 59 | }; 60 | } 61 | -------------------------------------------------------------------------------- /source/quad_var/ex_qts.c: -------------------------------------------------------------------------------- 1 | /* openAPL, Copyright (C) Branko Bratkovic 1998 2 | * This file is free software and is covered by the GNU General 3 | * Public License. 4 | * 5 | * This program is distributed in the hope that it will be useful, 6 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 7 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. 8 | * 9 | * For more details see the GNU General Public License (GPL) in 10 | * the docs directory. 11 | */ 12 | 13 | #include 14 | #include 15 | #include "apl.h" 16 | #include "utility.h" 17 | #include "data.h" 18 | 19 | item_t* ex_qts(io) int io; /* 0 = source, 1 = sink */ 20 | { 21 | item_t* p; 22 | struct tm* tp; 23 | struct timeval tv; 24 | struct timezone tz; 25 | long tvec; 26 | 27 | if (io == 0) { 28 | p = newdat(DA, 1, 7); 29 | 30 | /* get time information from the OS */ 31 | time(&tvec); 32 | tp = localtime(&tvec); 33 | gettimeofday(&tv, &tz); 34 | 35 | /* load time into item *p */ 36 | p->datap[0] = tp->tm_year + 1900; 37 | p->datap[1] = tp->tm_mon + 1; 38 | p->datap[2] = tp->tm_mday; 39 | p->datap[3] = tp->tm_hour; 40 | p->datap[4] = tp->tm_min; 41 | p->datap[5] = tp->tm_sec; 42 | p->datap[6] = tv.tv_usec / 1000; 43 | 44 | return (p); 45 | } 46 | else { 47 | error(ERR_implicit, "cannot change time"); 48 | return (0); 49 | }; 50 | } 51 | -------------------------------------------------------------------------------- /source/scalar_dyadic/Makefile: -------------------------------------------------------------------------------- 1 | # Makefile for scalar_dyadic (dyadic scalar functions) 2 | 3 | include ../include/makefile.common 4 | CFLAGS += -I../include 5 | 6 | OBJECTS = ex_cir.o ex_gt.o ex_min.o ex_ne.o ex_pwr.o ex_comb.o \ 7 | ex_le.o ex_minus.o ex_sub.o ex_div.o ex_log.o \ 8 | ex_mod.o ex_nor.o ex_add.o ex_eq.o ex_lt.o ex_mul.o ex_or.o \ 9 | ex_and.o ex_ge.o ex_max.o ex_nand.o ex_plus.o 10 | 11 | all: Q.o 12 | 13 | Q.o: $(OBJECTS) 14 | $(LD) -r -o Q.o $(OBJECTS) 15 | 16 | $(OBJECTS): ../include/apl.h 17 | 18 | .c.o: 19 | $(CC) $(CFLAGS) -c $< 20 | 21 | clean: 22 | rm -f $(OBJECTS) core Q.o 23 | -------------------------------------------------------------------------------- /source/scalar_dyadic/ex_add.c: -------------------------------------------------------------------------------- 1 | /* Copyright U S WEST Advanced Technologies, Inc. 2 | * You may use, copy, modify and sublicense this Software 3 | * subject to the conditions expressed in the file "License". 4 | */ 5 | 6 | #include "apl.h" 7 | #include "utility.h" 8 | 9 | data 10 | ex_add(d1, d2) 11 | data d1, 12 | d2; 13 | { 14 | if (fuzz(d1, -d2) == 0) 15 | return (zero); 16 | return (d1 + d2); 17 | } 18 | -------------------------------------------------------------------------------- /source/scalar_dyadic/ex_and.c: -------------------------------------------------------------------------------- 1 | /* Copyright U S WEST Advanced Technologies, Inc. 2 | * You may use, copy, modify and sublicense this Software 3 | * subject to the conditions expressed in the file "License". 4 | */ 5 | 6 | #include "apl.h" 7 | 8 | data 9 | ex_and(d1, d2) 10 | data d1, 11 | d2; 12 | { 13 | if (d1 != zero && d2 != zero) 14 | return (one); 15 | return (zero); 16 | } 17 | -------------------------------------------------------------------------------- /source/scalar_dyadic/ex_comb.c: -------------------------------------------------------------------------------- 1 | /* Copyright U S WEST Advanced Technologies, Inc. 2 | * You may use, copy, modify and sublicense this Software 3 | * subject to the conditions expressed in the file "License". 4 | */ 5 | 6 | #include "apl.h" 7 | #include "utility.h" 8 | #include 9 | 10 | data 11 | ex_comb(d1, d2) 12 | data d1, 13 | d2; 14 | { 15 | double f; 16 | 17 | if (d1 > d2) 18 | return (zero); 19 | f = gamma(d2 + 1.) - gamma(d1 + 1.) - gamma(d2 - d1 + 1.); 20 | if (f > MAXEXP) 21 | error(ERR_limit, "input range overflow"); 22 | d1 = exp(f); 23 | return (d1); 24 | } 25 | -------------------------------------------------------------------------------- /source/scalar_dyadic/ex_div.c: -------------------------------------------------------------------------------- 1 | /* Copyright U S WEST Advanced Technologies, Inc. 2 | * You may use, copy, modify and sublicense this Software 3 | * subject to the conditions expressed in the file "License". 4 | */ 5 | 6 | #include "apl.h" 7 | #include "utility.h" 8 | 9 | data 10 | ex_div(d1, d2) 11 | data d1, 12 | d2; 13 | { 14 | /* 0 div 0 is 1 */ 15 | if (d2 == zero) { 16 | if (d1 == zero) 17 | return (one); 18 | else 19 | error(ERR_implicit, "division by 0 attempted"); 20 | } 21 | return (d1 / d2); 22 | } 23 | -------------------------------------------------------------------------------- /source/scalar_dyadic/ex_eq.c: -------------------------------------------------------------------------------- 1 | /* Copyright U S WEST Advanced Technologies, Inc. 2 | * You may use, copy, modify and sublicense this Software 3 | * subject to the conditions expressed in the file "License". 4 | */ 5 | 6 | #include "apl.h" 7 | #include "utility.h" 8 | 9 | data 10 | ex_eq(d1, d2) 11 | data d1, 12 | d2; 13 | { 14 | if (fuzz(d1, d2) == 0) 15 | return (one); 16 | return (zero); 17 | } 18 | -------------------------------------------------------------------------------- /source/scalar_dyadic/ex_ge.c: -------------------------------------------------------------------------------- 1 | /* Copyright U S WEST Advanced Technologies, Inc. 2 | * You may use, copy, modify and sublicense this Software 3 | * subject to the conditions expressed in the file "License". 4 | */ 5 | 6 | #include "apl.h" 7 | #include "utility.h" 8 | 9 | data 10 | ex_ge(d1, d2) 11 | data d1, 12 | d2; 13 | { 14 | if (fuzz(d1, d2) >= 0) 15 | return (one); 16 | return (zero); 17 | } 18 | -------------------------------------------------------------------------------- /source/scalar_dyadic/ex_gt.c: -------------------------------------------------------------------------------- 1 | /* Copyright U S WEST Advanced Technologies, Inc. 2 | * You may use, copy, modify and sublicense this Software 3 | * subject to the conditions expressed in the file "License". 4 | */ 5 | 6 | #include "apl.h" 7 | #include "utility.h" 8 | 9 | data 10 | ex_gt(d1, d2) 11 | data d1, 12 | d2; 13 | { 14 | if (fuzz(d1, d2) > 0) 15 | return (one); 16 | return (zero); 17 | } 18 | -------------------------------------------------------------------------------- /source/scalar_dyadic/ex_le.c: -------------------------------------------------------------------------------- 1 | /* Copyright U S WEST Advanced Technologies, Inc. 2 | * You may use, copy, modify and sublicense this Software 3 | * subject to the conditions expressed in the file "License". 4 | */ 5 | 6 | #include "apl.h" 7 | #include "utility.h" 8 | 9 | data 10 | ex_le(d1, d2) 11 | data d1, 12 | d2; 13 | { 14 | if (fuzz(d1, d2) <= 0) 15 | return (one); 16 | return (zero); 17 | } 18 | -------------------------------------------------------------------------------- /source/scalar_dyadic/ex_log.c: -------------------------------------------------------------------------------- 1 | /* Copyright U S WEST Advanced Technologies, Inc. 2 | * You may use, copy, modify and sublicense this Software 3 | * subject to the conditions expressed in the file "License". 4 | */ 5 | 6 | #include "apl.h" 7 | #include "utility.h" 8 | #include 9 | 10 | data 11 | ex_log(d1, d2) 12 | data d1, 13 | d2; 14 | { 15 | double f1, f2; 16 | 17 | f1 = d1; 18 | f2 = d2; 19 | if (f1 <= 0. || f2 <= 0.) 20 | error(ERR_implicit, "log of a negative number attempted"); 21 | d1 = log(f2) / log(f1); 22 | return (d1); 23 | } 24 | -------------------------------------------------------------------------------- /source/scalar_dyadic/ex_lt.c: -------------------------------------------------------------------------------- 1 | /* Copyright U S WEST Advanced Technologies, Inc. 2 | * You may use, copy, modify and sublicense this Software 3 | * subject to the conditions expressed in the file "License". 4 | */ 5 | 6 | #include "apl.h" 7 | #include "utility.h" 8 | 9 | data 10 | ex_lt(d1, d2) 11 | data d1, 12 | d2; 13 | { 14 | if (fuzz(d1, d2) < 0) 15 | return (one); 16 | return (zero); 17 | } 18 | -------------------------------------------------------------------------------- /source/scalar_dyadic/ex_max.c: -------------------------------------------------------------------------------- 1 | /* Copyright U S WEST Advanced Technologies, Inc. 2 | * You may use, copy, modify and sublicense this Software 3 | * subject to the conditions expressed in the file "License". 4 | */ 5 | 6 | #include "apl.h" 7 | 8 | data 9 | ex_max(d1, d2) 10 | data d1, 11 | d2; 12 | { 13 | if (d1 > d2) 14 | return (d1); 15 | return (d2); 16 | } 17 | -------------------------------------------------------------------------------- /source/scalar_dyadic/ex_min.c: -------------------------------------------------------------------------------- 1 | /* Copyright U S WEST Advanced Technologies, Inc. 2 | * You may use, copy, modify and sublicense this Software 3 | * subject to the conditions expressed in the file "License". 4 | */ 5 | 6 | #include "apl.h" 7 | 8 | data 9 | ex_min(d1, d2) 10 | data d1, 11 | d2; 12 | { 13 | if (d1 < d2) 14 | return (d1); 15 | return (d2); 16 | } 17 | -------------------------------------------------------------------------------- /source/scalar_dyadic/ex_minus.c: -------------------------------------------------------------------------------- 1 | /* Copyright U S WEST Advanced Technologies, Inc. 2 | * You may use, copy, modify and sublicense this Software 3 | * subject to the conditions expressed in the file "License". 4 | */ 5 | 6 | #include "apl.h" 7 | 8 | data 9 | ex_minus(d) 10 | data d; 11 | { 12 | return (-d); 13 | } 14 | -------------------------------------------------------------------------------- /source/scalar_dyadic/ex_mod.c: -------------------------------------------------------------------------------- 1 | /* Copyright U S WEST Advanced Technologies, Inc. 2 | * You may use, copy, modify and sublicense this Software 3 | * subject to the conditions expressed in the file "License". 4 | */ 5 | 6 | #include "apl.h" 7 | #include 8 | 9 | data 10 | ex_mod(d1, d2) 11 | data d1, 12 | d2; 13 | { 14 | /* x mod 0 is defined to be x */ 15 | if (d1 == zero) 16 | return (d2); 17 | d2 = d2 - d1 * floor(MINFLOAT + d2 / d1); 18 | if (fabs(d2) < tolerance) 19 | return (0); 20 | if (fabs(d2 - d1) < tolerance) 21 | return (0); 22 | if (d2 == d1) 23 | return (0); 24 | return (d2); 25 | } 26 | -------------------------------------------------------------------------------- /source/scalar_dyadic/ex_mul.c: -------------------------------------------------------------------------------- 1 | /* Copyright U S WEST Advanced Technologies, Inc. 2 | * You may use, copy, modify and sublicense this Software 3 | * subject to the conditions expressed in the file "License". 4 | */ 5 | 6 | #include "apl.h" 7 | 8 | data 9 | ex_mul(d1, d2) 10 | data d1, 11 | d2; 12 | { 13 | return (d1 * d2); 14 | } 15 | -------------------------------------------------------------------------------- /source/scalar_dyadic/ex_nand.c: -------------------------------------------------------------------------------- 1 | /* Copyright U S WEST Advanced Technologies, Inc. 2 | * You may use, copy, modify and sublicense this Software 3 | * subject to the conditions expressed in the file "License". 4 | */ 5 | 6 | #include "apl.h" 7 | 8 | data 9 | ex_nand(d1, d2) 10 | data d1, 11 | d2; 12 | { 13 | if (d1 != zero && d2 != zero) 14 | return (zero); 15 | return (one); 16 | } 17 | -------------------------------------------------------------------------------- /source/scalar_dyadic/ex_ne.c: -------------------------------------------------------------------------------- 1 | /* Copyright U S WEST Advanced Technologies, Inc. 2 | * You may use, copy, modify and sublicense this Software 3 | * subject to the conditions expressed in the file "License". 4 | */ 5 | 6 | #include "apl.h" 7 | #include "utility.h" 8 | 9 | data 10 | ex_ne(d1, d2) 11 | data d1, 12 | d2; 13 | { 14 | if (fuzz(d1, d2) != 0) 15 | return (one); 16 | return (zero); 17 | } 18 | -------------------------------------------------------------------------------- /source/scalar_dyadic/ex_nor.c: -------------------------------------------------------------------------------- 1 | /* Copyright U S WEST Advanced Technologies, Inc. 2 | * You may use, copy, modify and sublicense this Software 3 | * subject to the conditions expressed in the file "License". 4 | */ 5 | 6 | #include "apl.h" 7 | 8 | data 9 | ex_nor(d1, d2) 10 | data d1, 11 | d2; 12 | { 13 | if (d1 != zero || d2 != zero) 14 | return (zero); 15 | return (one); 16 | } 17 | -------------------------------------------------------------------------------- /source/scalar_dyadic/ex_or.c: -------------------------------------------------------------------------------- 1 | /* Copyright U S WEST Advanced Technologies, Inc. 2 | * You may use, copy, modify and sublicense this Software 3 | * subject to the conditions expressed in the file "License". 4 | */ 5 | 6 | #include "apl.h" 7 | 8 | data 9 | ex_or(d1, d2) 10 | data d1, 11 | d2; 12 | { 13 | if (d1 != zero || d2 != zero) 14 | return (one); 15 | return (zero); 16 | } 17 | -------------------------------------------------------------------------------- /source/scalar_dyadic/ex_plus.c: -------------------------------------------------------------------------------- 1 | /* Copyright U S WEST Advanced Technologies, Inc. 2 | * You may use, copy, modify and sublicense this Software 3 | * subject to the conditions expressed in the file "License". 4 | */ 5 | 6 | #include "apl.h" 7 | 8 | data 9 | ex_plus(d) 10 | data d; 11 | { 12 | return (d); 13 | } 14 | -------------------------------------------------------------------------------- /source/scalar_dyadic/ex_pwr.c: -------------------------------------------------------------------------------- 1 | /* Copyright U S WEST Advanced Technologies, Inc. 2 | * You may use, copy, modify and sublicense this Software 3 | * subject to the conditions expressed in the file "License". 4 | */ 5 | 6 | #include "apl.h" 7 | #include "utility.h" 8 | #include 9 | 10 | data ex_pwr(data d1, data d2) { 11 | int s; 12 | double f1, f2; 13 | 14 | s = 0; 15 | f1 = d1; 16 | if (f1 > 0.) { 17 | f1 = d2 * log(f1); 18 | goto chk; 19 | } 20 | if (f1 == 0.) 21 | return (d2 == zero ? (data)1.0 : zero); 22 | 23 | /* check for integer exponent */ 24 | f2 = floor(d2); 25 | if (fabs(d2 - f2) < tolerance) { 26 | s = (int)f2 % 2; 27 | f1 = d2 * log(fabs(f1)); 28 | goto chk; 29 | } 30 | /* should check rational d2 here */ 31 | goto bad; 32 | 33 | chk: 34 | if (f1 < MAXEXP) { 35 | d1 = exp(f1); 36 | if (s) 37 | d1 = -d1; 38 | return (d1); 39 | } 40 | bad: 41 | error(ERR_limit, "input range to pwr()"); 42 | return (0); 43 | } 44 | -------------------------------------------------------------------------------- /source/scalar_dyadic/ex_sub.c: -------------------------------------------------------------------------------- 1 | /* Copyright U S WEST Advanced Technologies, Inc. 2 | * You may use, copy, modify and sublicense this Software 3 | * subject to the conditions expressed in the file "License". 4 | */ 5 | 6 | #include "apl.h" 7 | #include "utility.h" 8 | 9 | data 10 | ex_sub(d1, d2) 11 | data d1, 12 | d2; 13 | { 14 | if (fuzz(d1, d2) == 0) 15 | return (zero); 16 | return (d1 - d2); 17 | } 18 | -------------------------------------------------------------------------------- /source/scalar_monadic/Makefile: -------------------------------------------------------------------------------- 1 | # Makefile for scalar_monadic (monadic scalar functions) 2 | 3 | include ../include/makefile.common 4 | CFLAGS += -I../include 5 | 6 | OBJECTS = ex_abs.o ex_fac.o ex_not.o ex_sgn.o ex_ceil.o \ 7 | ex_floor.o ex_pi.o ex_exp.o ex_loge.o ex_recip.o 8 | 9 | all: Q.o 10 | 11 | Q.o: $(OBJECTS) 12 | $(LD) -r -o Q.o $(OBJECTS) 13 | 14 | $(OBJECTS): ../include/apl.h 15 | 16 | .c.o: 17 | $(CC) $(CFLAGS) -c $< 18 | 19 | clean: 20 | rm -f *.o 21 | -------------------------------------------------------------------------------- /source/scalar_monadic/ex_abs.c: -------------------------------------------------------------------------------- 1 | /* Copyright U S WEST Advanced Technologies, Inc. 2 | * You may use, copy, modify and sublicense this Software 3 | * subject to the conditions expressed in the file "License". 4 | */ 5 | 6 | #include "apl.h" 7 | 8 | data 9 | ex_abs(d) 10 | data d; 11 | { 12 | if (d < zero) 13 | return (-d); 14 | return (d); 15 | } 16 | -------------------------------------------------------------------------------- /source/scalar_monadic/ex_ceil.c: -------------------------------------------------------------------------------- 1 | /* Copyright U S WEST Advanced Technologies, Inc. 2 | * You may use, copy, modify and sublicense this Software 3 | * subject to the conditions expressed in the file "License". 4 | */ 5 | 6 | #include "apl.h" 7 | #include "math.h" 8 | 9 | data 10 | ex_ceil(d) 11 | data d; 12 | { 13 | d = ceil(d - tolerance); 14 | return (d); 15 | } 16 | -------------------------------------------------------------------------------- /source/scalar_monadic/ex_exp.c: -------------------------------------------------------------------------------- 1 | /* Copyright U S WEST Advanced Technologies, Inc. 2 | * You may use, copy, modify and sublicense this Software 3 | * subject to the conditions expressed in the file "License". 4 | */ 5 | 6 | #include "apl.h" 7 | #include "utility.h" 8 | #include 9 | 10 | data 11 | ex_exp(d) 12 | data d; 13 | { 14 | double f; 15 | 16 | f = d; 17 | if (f > MAXEXP) 18 | error(ERR_limit, "input value to exp function"); 19 | d = exp(f); 20 | return (d); 21 | } 22 | -------------------------------------------------------------------------------- /source/scalar_monadic/ex_fac.c: -------------------------------------------------------------------------------- 1 | /* Copyright U S WEST Advanced Technologies, Inc. 2 | * You may use, copy, modify and sublicense this Software 3 | * subject to the conditions expressed in the file "License". 4 | */ 5 | 6 | #include "apl.h" 7 | #include "utility.h" 8 | #include 9 | 10 | data 11 | ex_fac(d) 12 | data d; 13 | { 14 | double f; 15 | 16 | f = gamma(d + 1.); 17 | if (f > MAXEXP) 18 | error(ERR_limit, "input to factorial function"); 19 | d = exp(f); 20 | if (signgamma < 0) 21 | d = -d; /* if (signgamma) in version 6 */ 22 | return (d); 23 | } 24 | -------------------------------------------------------------------------------- /source/scalar_monadic/ex_floor.c: -------------------------------------------------------------------------------- 1 | /* Copyright U S WEST Advanced Technologies, Inc. 2 | * You may use, copy, modify and sublicense this Software 3 | * subject to the conditions expressed in the file "License". 4 | */ 5 | 6 | #include "apl.h" 7 | #include 8 | 9 | data 10 | ex_floor(d) 11 | data d; 12 | { 13 | d = floor(d + tolerance); 14 | return (d); 15 | } 16 | -------------------------------------------------------------------------------- /source/scalar_monadic/ex_loge.c: -------------------------------------------------------------------------------- 1 | /* Copyright U S WEST Advanced Technologies, Inc. 2 | * You may use, copy, modify and sublicense this Software 3 | * subject to the conditions expressed in the file "License". 4 | */ 5 | 6 | #include "apl.h" 7 | #include "utility.h" 8 | #include 9 | 10 | data 11 | ex_loge(d) 12 | data d; 13 | { 14 | double f; 15 | 16 | f = d; 17 | if (f <= 0.) 18 | error(ERR_limit, "log of negative number attempted"); 19 | d = log(f); 20 | return (d); 21 | } 22 | -------------------------------------------------------------------------------- /source/scalar_monadic/ex_not.c: -------------------------------------------------------------------------------- 1 | /* Copyright U S WEST Advanced Technologies, Inc. 2 | * You may use, copy, modify and sublicense this Software 3 | * subject to the conditions expressed in the file "License". 4 | */ 5 | 6 | #include "apl.h" 7 | 8 | data 9 | ex_not(d) 10 | data d; 11 | { 12 | if (d == zero) 13 | return (one); 14 | return (zero); 15 | } 16 | -------------------------------------------------------------------------------- /source/scalar_monadic/ex_pi.c: -------------------------------------------------------------------------------- 1 | /* Copyright U S WEST Advanced Technologies, Inc. 2 | * You may use, copy, modify and sublicense this Software 3 | * subject to the conditions expressed in the file "License". 4 | */ 5 | 6 | #include "apl.h" 7 | 8 | data 9 | ex_pi(d) 10 | data d; 11 | { 12 | d = pi * d; 13 | return (d); 14 | } 15 | -------------------------------------------------------------------------------- /source/scalar_monadic/ex_recip.c: -------------------------------------------------------------------------------- 1 | /* Copyright U S WEST Advanced Technologies, Inc. 2 | * You may use, copy, modify and sublicense this Software 3 | * subject to the conditions expressed in the file "License". 4 | */ 5 | 6 | #include "apl.h" 7 | #include "utility.h" 8 | 9 | data 10 | ex_recip(d) 11 | data d; 12 | { 13 | if (d == zero) 14 | error(ERR_domain, "reciprocal of zero attempted"); 15 | return (one / d); 16 | } 17 | -------------------------------------------------------------------------------- /source/scalar_monadic/ex_sgn.c: -------------------------------------------------------------------------------- 1 | /* Copyright U S WEST Advanced Technologies, Inc. 2 | * You may use, copy, modify and sublicense this Software 3 | * subject to the conditions expressed in the file "License". 4 | */ 5 | 6 | #include "apl.h" 7 | 8 | data 9 | ex_sgn(d) 10 | data d; 11 | { 12 | if (d == zero) 13 | return (zero); 14 | if (d < zero) 15 | return (-one); 16 | return (one); 17 | } 18 | -------------------------------------------------------------------------------- /source/struct_dyadic/Makefile: -------------------------------------------------------------------------------- 1 | # Makefile for struct_dyadic (structural dyadic operators) 2 | 3 | include ../include/makefile.common 4 | CFLAGS += -I../include 5 | 6 | OBJECTS = ex_cat.o ex_drho.o 7 | 8 | all: Q.o 9 | 10 | Q.o: $(OBJECTS) 11 | $(LD) -r -o Q.o $(OBJECTS) 12 | 13 | $(OBJECTS): ../include/apl.h 14 | 15 | .c.o: 16 | $(CC) $(CFLAGS) -c $< 17 | 18 | clean: 19 | rm -f $(OBJECTS) core 20 | -------------------------------------------------------------------------------- /source/struct_monadic/Makefile: -------------------------------------------------------------------------------- 1 | # Makefile for struct_monadic 2 | 3 | include ../include/makefile.common 4 | CFLAGS += -I../include 5 | 6 | OBJECTS = ex_mrho.o ex_miot.o ex_rav.o 7 | 8 | all: Q.o 9 | 10 | Q.o: $(OBJECTS) 11 | $(LD) -r -o Q.o $(OBJECTS) 12 | 13 | $(OBJECTS): ../include/apl.h 14 | 15 | .c.o: 16 | $(CC) $(CFLAGS) -c $< 17 | 18 | clean: 19 | rm -f $(OBJECTS) core 20 | -------------------------------------------------------------------------------- /source/struct_monadic/ex_miot.c: -------------------------------------------------------------------------------- 1 | /* Copyright U S WEST Advanced Technologies, Inc. 2 | * You may use, copy, modify and sublicense this Software 3 | * subject to the conditions expressed in the file "License". 4 | */ 5 | #include "apl.h" 6 | #include "utility.h" 7 | #include "data.h" 8 | 9 | void ex_miot() 10 | { 11 | item_t* p; 12 | data* dp; 13 | int i; 14 | 15 | i = topfix(); 16 | if (i < 0) { /* must allocate something to ")sic" properly */ 17 | *expr_stack_ptr++ = newdat(DA, 1, 0); 18 | error(ERR_domain, "right value is less than 0"); 19 | } 20 | p = newdat(DA, 1, i); 21 | dp = p->datap; 22 | datum = iorigin; 23 | for (; i; i--) { 24 | *dp++ = datum; 25 | datum += one; 26 | } 27 | *expr_stack_ptr++ = p; 28 | } 29 | -------------------------------------------------------------------------------- /source/struct_monadic/ex_mrho.c: -------------------------------------------------------------------------------- 1 | /* Copyright U S WEST Advanced Technologies, Inc. 2 | * You may use, copy, modify and sublicense this Software 3 | * subject to the conditions expressed in the file "License". 4 | */ 5 | #include "apl.h" 6 | #include "data.h" 7 | 8 | void ex_mrho() 9 | { 10 | item_t *p, *q; 11 | data* dp; 12 | int i; 13 | 14 | p = fetch1(); 15 | q = newdat(DA, 1, p->rank); 16 | dp = q->datap; 17 | for (i = 0; i < p->rank; i++) 18 | *dp++ = p->dim[i]; 19 | pop(); 20 | *expr_stack_ptr++ = q; 21 | } 22 | -------------------------------------------------------------------------------- /source/struct_monadic/ex_rav.c: -------------------------------------------------------------------------------- 1 | /* Copyright U S WEST Advanced Technologies, Inc. 2 | * You may use, copy, modify and sublicense this Software 3 | * subject to the conditions expressed in the file "License". 4 | */ 5 | 6 | #include "apl.h" 7 | #include "data.h" 8 | #include "utility.h" 9 | 10 | static void rav0(int k); 11 | static void rav1(item_t* p, item_t* dest); 12 | 13 | void ex_rav() 14 | { 15 | item_t *p, *r; 16 | 17 | p = fetch1(); 18 | if (p->rank == 0) { 19 | r = newdat(p->itemType, 1, 1); 20 | putdat(r, getdat(p)); 21 | pop(); 22 | *expr_stack_ptr++ = r; 23 | return; 24 | } 25 | rav0(p->rank - 1); 26 | } 27 | 28 | void ex_ravk() 29 | { 30 | int i; 31 | 32 | i = topfix() - iorigin; 33 | fetch1(); 34 | rav0(i); 35 | } 36 | 37 | static void rav0(int k) 38 | { 39 | item_t *p, *r; 40 | 41 | p = expr_stack_ptr[-1]; 42 | bidx(p); 43 | colapse(k); 44 | r = newdat(p->itemType, 1, p->size); 45 | 46 | indexIterateInit(&idx); 47 | while (indexIterate(&idx)) { 48 | rav1(p, r); 49 | } 50 | 51 | pop(); 52 | *expr_stack_ptr++ = r; 53 | } 54 | 55 | static void rav1(item_t* p, item_t* dest) 56 | { 57 | int i, n; 58 | 59 | n = access(); 60 | for (i = 0; i < idx.dimk; i++) { 61 | p->index = n; 62 | putdat(dest, getdat(p)); 63 | n += idx.delk; 64 | } 65 | } 66 | -------------------------------------------------------------------------------- /source/sys_command/Makefile: -------------------------------------------------------------------------------- 1 | # Makefile for syscom (system commands) 2 | 3 | include ../include/makefile.common 4 | CFLAGS += -I../include 5 | 6 | OBJECTS = ex_syscom.o ex_prws.o ex_shell.o listdir.o ex_list.o 7 | 8 | all: Q.o 9 | 10 | Q.o: $(OBJECTS) 11 | $(LD) -r -o Q.o $(OBJECTS) 12 | 13 | $(OBJECTS): ../include/apl.h 14 | 15 | ex_prws.o: ../include/char.h 16 | 17 | ex_syscom.o: ../include/opt_codes.h 18 | 19 | .c.o: 20 | $(CC) $(CFLAGS) -c $< 21 | 22 | clean: 23 | rm -f $(OBJECTS) core 24 | 25 | -------------------------------------------------------------------------------- /source/sys_command/ex_list.h: -------------------------------------------------------------------------------- 1 | /* ex_list.h, Copyright (C) 2016, Greg Johnson 2 | * Released under the terms of the GNU GPL v2.0. 3 | * 4 | * This program is distributed in the hope that it will be useful, 5 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 6 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 7 | * GNU General Public License for more details. 8 | */ 9 | #ifndef EX_LIST_H 10 | #define EX_LIST_H 11 | 12 | void ex_list(); 13 | 14 | #endif 15 | -------------------------------------------------------------------------------- /source/sys_command/ex_prws.c: -------------------------------------------------------------------------------- 1 | /* Copyright U S WEST Advanced Technologies, Inc. 2 | * You may use, copy, modify and sublicense this Software 3 | * subject to the conditions expressed in the file "License". 4 | */ 5 | #include 6 | 7 | #include "apl.h" 8 | #include "data.h" 9 | #include "char.h" 10 | #include "ex_list.h" 11 | #include "print.h" 12 | 13 | /* Print Workspace */ 14 | void ex_prws() 15 | { 16 | SymTabEntry* np; 17 | item_t* ip; 18 | int i; 19 | 20 | printf(S_QUAD_ASCII "io " S_LEFTARROW " %d\n", iorigin); 21 | printf(S_QUAD_ASCII "pw " S_LEFTARROW " %d\n", pagewidth); 22 | printf(S_QUAD_ASCII "pp " S_LEFTARROW " %d\n", PrintP); 23 | 24 | symtabIterateInit(); 25 | while ((np = symtabIterate()) != NULL) { 26 | switch (np->entryUse) { 27 | case CH: 28 | case DA: 29 | printf("%s " S_LEFTARROW " ", np->namep); 30 | ip = np->itemp; 31 | if (ip->rank) { 32 | for (i = 0; i < ip->rank; i++) 33 | printf("%d ", ip->dim[i]); 34 | printf(S_RHO "\n"); 35 | } 36 | *expr_stack_ptr++ = (item_t*)np; 37 | ex_print(); 38 | pop(); 39 | putchar('\n'); 40 | break; 41 | 42 | case NF: 43 | case MF: 44 | case DF: 45 | *expr_stack_ptr++ = (item_t*)np; 46 | ex_list(); 47 | putchar('\n'); 48 | break; 49 | 50 | default: 51 | break; 52 | } 53 | } 54 | } 55 | -------------------------------------------------------------------------------- /source/sys_command/ex_prws.h: -------------------------------------------------------------------------------- 1 | /* ex_prws.h, Copyright (C) 2016, Greg Johnson 2 | * Released under the terms of the GNU GPL v2.0. 3 | * 4 | * This program is distributed in the hope that it will be useful, 5 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 6 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 7 | * GNU General Public License for more details. 8 | */ 9 | #ifndef EX_PRWS_H 10 | #define EX_PRWS_H 11 | 12 | void ex_prws(); 13 | 14 | #endif 15 | -------------------------------------------------------------------------------- /source/sys_command/ex_shell.c: -------------------------------------------------------------------------------- 1 | /* Copyright U S WEST Advanced Technologies, Inc. 2 | * You may use, copy, modify and sublicense this Software 3 | * subject to the conditions expressed in the file "License". 4 | */ 5 | #include 6 | 7 | #include "apl.h" 8 | #include "utility.h" 9 | 10 | /* If the environment variable SHELL is defined, attempt to 11 | * execute that shell. If not, or if that exec fails, attempt 12 | * to execute the standard shell, /bin/sh 13 | */ 14 | void ex_shell() 15 | { 16 | char *getenv(), *sh; 17 | 18 | sh = getenv("SHELL"); 19 | if (sh == 0) 20 | sh = "/bin/sh"; 21 | if (system(sh) == -1) 22 | error(ERR, "attempt to start shell failed"); 23 | } 24 | -------------------------------------------------------------------------------- /source/sys_command/ex_shell.h: -------------------------------------------------------------------------------- 1 | /* ex_shell.h, Copyright (C) 2016, Greg Johnson 2 | * Released under the terms of the GNU GPL v2.0. 3 | * 4 | * This program is distributed in the hope that it will be useful, 5 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 6 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 7 | * GNU General Public License for more details. 8 | */ 9 | #ifndef EX_SHELL_H 10 | #define EX_SHELL_H 11 | 12 | void ex_shell(); 13 | 14 | #endif 15 | -------------------------------------------------------------------------------- /source/sys_command/listdir.c: -------------------------------------------------------------------------------- 1 | /* Copyright U S WEST Advanced Technologies, Inc. 2 | * You may use, copy, modify and sublicense this Software 3 | * subject to the conditions expressed in the file "License". 4 | */ 5 | #include 6 | 7 | #include "apl.h" 8 | #include "utility.h" 9 | 10 | void listdir() 11 | { 12 | DIR* thisDirectory; 13 | struct dirent* entry; 14 | int i; 15 | 16 | thisDirectory = opendir("."); 17 | if (thisDirectory == 0) 18 | error(ERR_botch, "could not open CWD"); 19 | while (1) { 20 | entry = readdir(thisDirectory); 21 | if (entry == 0) 22 | break; 23 | if (entry->d_ino != 0 && entry->d_name[0] != '.') { 24 | if (column + 10 >= pagewidth) 25 | printf("\n\t"); 26 | for (i = 0; i < 14 && entry->d_name[i]; i++) 27 | putchar(entry->d_name[i]); 28 | putchar('\t'); 29 | } 30 | } 31 | putchar('\n'); 32 | closedir(thisDirectory); 33 | } 34 | -------------------------------------------------------------------------------- /source/sys_command/listdir.h: -------------------------------------------------------------------------------- 1 | /* listdir.h, Copyright (C) 2016, Greg Johnson 2 | * Released under the terms of the GNU GPL v2.0. 3 | * 4 | * This program is distributed in the hope that it will be useful, 5 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 6 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 7 | * GNU General Public License for more details. 8 | */ 9 | #ifndef LISTDIR_H 10 | #define LISTDIR_H 11 | 12 | void listdir(); 13 | 14 | #endif 15 | -------------------------------------------------------------------------------- /source/userfunc/Makefile: -------------------------------------------------------------------------------- 1 | # Makefile for userfunc (user defined functions) 2 | 3 | include ../include/makefile.common 4 | CFLAGS += -I../include -I../parser 5 | 6 | OBJECTS = ex_auto.o ex_fun.o ex_nilret.o fundef.o \ 7 | csize.o ex_br.o ex_ibr.o ex_rest.o funedit.o sichk.o \ 8 | ex_arg1.o ex_ibr0.o funread.o tback.o \ 9 | ex_arg2.o ex_label.o funcomp.o funwrite.o \ 10 | funstdin.o context.o 11 | 12 | all: Q.o 13 | 14 | Q.o: $(OBJECTS) 15 | $(LD) -r -o Q.o $(OBJECTS) 16 | 17 | $(OBJECTS): ../include/apl.h 18 | 19 | # Things that depend on characters 20 | ex_fdef.o ex_ibr.o ex_ibr0.o: ../include/char.h 21 | 22 | csize.o funcomp.o: ../include/opt_codes.h 23 | 24 | .c.o: 25 | $(CC) $(CFLAGS) -c $< 26 | 27 | clean: 28 | rm -f $(OBJECTS) core 29 | 30 | -------------------------------------------------------------------------------- /source/userfunc/context.c: -------------------------------------------------------------------------------- 1 | #include 2 | #include "apl.h" 3 | #include "memory.h" 4 | #include "userfunc.h" 5 | 6 | Context *Context_new() { 7 | Context *context = (Context *) alloc(sizeof(Context)); 8 | memset(context, 0, sizeof(Context)); 9 | } 10 | 11 | void Context_addShadowedId(Context *context, SymTabEntry *entry) { 12 | // "realloc" shadowedId vector if necessary.. 13 | // 14 | if (context->shadowedIdCount == context->shadowedIdSize) { 15 | context->shadowedIdSize = 1 + 2 * context->shadowedIdSize; 16 | 17 | int size = context->shadowedIdSize * sizeof(SymTabEntry*); 18 | SymTabEntry **entries = (SymTabEntry **) alloc(size); 19 | 20 | memcpy(entries, 21 | context->shadowedIds, 22 | context->shadowedIdCount * sizeof(SymTabEntry*)); 23 | 24 | aplfree((int *) context->shadowedIds); 25 | 26 | context->shadowedIds = entries; 27 | } 28 | 29 | context->shadowedIds[context->shadowedIdCount++] = entry; 30 | } 31 | -------------------------------------------------------------------------------- /source/userfunc/csize.c: -------------------------------------------------------------------------------- 1 | /* Copyright U S WEST Advanced Technologies, Inc. 2 | * You may use, copy, modify and sublicense this Software 3 | * subject to the conditions expressed in the file "License". 4 | */ 5 | #include "apl.h" 6 | #include "opt_codes.h" 7 | 8 | /* 9 | * csize -- return size (in bytes) of a compiled string 10 | */ 11 | int csize(char* s) { 12 | int c, len; 13 | char* p; 14 | 15 | len = 1; 16 | p = s; 17 | while ((c = *p++) != END) { 18 | int i = 0; 19 | len++; 20 | c &= 0377; 21 | 22 | switch (c) { 23 | default: 24 | break; 25 | 26 | case QUOT: 27 | i = *p++; 28 | break; 29 | 30 | case CONST: 31 | i = *p++; 32 | i *= SDAT; 33 | len++; 34 | break; 35 | 36 | case NAME: case FUN: case ARG1: case ARG2: case AUTO: case REST: case RVAL: 37 | i = SPTR; 38 | break; 39 | } 40 | p += i; 41 | len += i; 42 | } 43 | 44 | return (len); 45 | } 46 | -------------------------------------------------------------------------------- /source/userfunc/ex_arg1.c: -------------------------------------------------------------------------------- 1 | /* Copyright U S WEST Advanced Technologies, Inc. 2 | * You may use, copy, modify and sublicense this Software 3 | * subject to the conditions expressed in the file "License". 4 | */ 5 | 6 | #include "apl.h" 7 | #include "data.h" 8 | #include "userfunc.h" 9 | 10 | void ex_arg1() { 11 | item_t* p; 12 | SymTabEntry* np; 13 | SymTabEntry* oldEntry; 14 | SymTabEntry* newEntry; 15 | 16 | state_indicator_ptr->ptr += copy(PTR, (char*) state_indicator_ptr->ptr, (char*) &np, 1); 17 | 18 | oldEntry = symtabFind(np->namep); 19 | if (oldEntry == NULL) { 20 | oldEntry = symtabEntryCreate(np->namep); 21 | } 22 | 23 | p = fetch(expr_stack_ptr[-1]); 24 | --expr_stack_ptr; 25 | 26 | Context_addShadowedId(state_indicator_ptr, oldEntry); 27 | 28 | symtabRemoveEntry(oldEntry); 29 | newEntry = symtabInsert(np->namep); 30 | 31 | newEntry->itemp = p; 32 | newEntry->entryUse = DA; 33 | } 34 | -------------------------------------------------------------------------------- /source/userfunc/ex_auto.c: -------------------------------------------------------------------------------- 1 | /* Copyright U S WEST Advanced Technologies, Inc. 2 | * You may use, copy, modify and sublicense this Software 3 | * subject to the conditions expressed in the file "License". 4 | */ 5 | 6 | #include "apl.h" 7 | #include "data.h" 8 | #include "utility.h" 9 | #include "userfunc.h" 10 | 11 | void ex_auto() 12 | { 13 | SymTabEntry* np; 14 | SymTabEntry* oldEntry; 15 | 16 | state_indicator_ptr->ptr += copy(PTR, (char*)state_indicator_ptr->ptr, (char*)&np, 1); 17 | 18 | oldEntry = symtabFind(np->namep); 19 | if (oldEntry == NULL) { 20 | oldEntry = symtabEntryCreate(np->namep); 21 | } 22 | 23 | checksp(); 24 | 25 | Context_addShadowedId(state_indicator_ptr, oldEntry); 26 | 27 | symtabRemoveEntry(oldEntry); 28 | 29 | symtabInsert(np->namep); 30 | } 31 | -------------------------------------------------------------------------------- /source/userfunc/ex_br.c: -------------------------------------------------------------------------------- 1 | /* Copyright U S WEST Advanced Technologies, Inc. 2 | * You may use, copy, modify and sublicense this Software 3 | * subject to the conditions expressed in the file "License". 4 | */ 5 | 6 | #include "apl.h" 7 | #include "utility.h" 8 | #include "mixed_dyadic.h" 9 | 10 | void ex_br() 11 | { 12 | item_t* p; 13 | 14 | p = fetch1(); 15 | if (p->size == 0) 16 | return; 17 | state_indicator_ptr->funlc = fix(getdat(p)); 18 | } 19 | 20 | void ex_br0() 21 | { 22 | state_indicator_ptr->funlc = 0; 23 | ex_elid(); 24 | } 25 | -------------------------------------------------------------------------------- /source/userfunc/ex_br0.c: -------------------------------------------------------------------------------- 1 | /* Copyright U S WEST Advanced Technologies, Inc. 2 | * You may use, copy, modify and sublicense this Software 3 | * subject to the conditions expressed in the file "License". 4 | */ 5 | 6 | #include "apl.h" 7 | -------------------------------------------------------------------------------- /source/userfunc/ex_ibr.c: -------------------------------------------------------------------------------- 1 | /* Copyright U S WEST Advanced Technologies, Inc. 2 | * You may use, copy, modify and sublicense this Software 3 | * subject to the conditions expressed in the file "License". 4 | */ 5 | 6 | #include "apl.h" 7 | #include "data.h" 8 | #include "utility.h" 9 | #include "char.h" 10 | #include "memory.h" 11 | #include "userfunc.h" 12 | 13 | /* 14 | * monadic interactive branch -- resume function at specific line 15 | */ 16 | 17 | void ex_ibr() 18 | { 19 | Context* thisContext; 20 | 21 | if (state_indicator_ptr == &prime_context || state_indicator_ptr->prev->suspended == 0) { 22 | error(ERR_implicit, "no suspended fn"); 23 | } 24 | 25 | /* pop current interactive context.. 26 | */ 27 | thisContext = state_indicator_ptr; 28 | state_indicator_ptr = state_indicator_ptr->prev; 29 | aplfree(thisContext); 30 | 31 | ex_br(); 32 | 33 | if (state_indicator_ptr->expr_stack_ptr == 0 || expr_stack_ptr < state_indicator_ptr->expr_stack_ptr) 34 | error(ERR_botch, "expr_stack pointer problem"); 35 | 36 | while (expr_stack_ptr > state_indicator_ptr->expr_stack_ptr) 37 | pop(); 38 | 39 | longjmp(state_indicator_ptr->env, 0); /* warp out */ 40 | } 41 | -------------------------------------------------------------------------------- /source/userfunc/ex_label.c: -------------------------------------------------------------------------------- 1 | /* Copyright U S WEST Advanced Technologies, Inc. 2 | * You may use, copy, modify and sublicense this Software 3 | * subject to the conditions expressed in the file "License". 4 | */ 5 | #include "apl.h" 6 | #include "data.h" 7 | #include "oper_dyadic.h" 8 | 9 | /* 10 | * parser generates the following for each label 11 | * 12 | * AUTO-name CONST NAME-name LABEL 13 | * 14 | * (where CONST is the label address) 15 | */ 16 | 17 | void ex_label() { 18 | SymTabEntry* n; 19 | SymTabEntry* newEntry; 20 | 21 | // create a new symtab entry.. 22 | n = (SymTabEntry*) expr_stack_ptr[-1]; 23 | symtabRemoveEntry(n); 24 | newEntry = symtabInsert(n->namep); 25 | newEntry->itemType = LV; 26 | 27 | expr_stack_ptr[-1] = (item_t *) newEntry; 28 | ex_asgn(); 29 | 30 | // lock out assignments 31 | newEntry->itemp->itemType = LBL; 32 | 33 | expr_stack_ptr--; 34 | } 35 | -------------------------------------------------------------------------------- /source/userfunc/ex_nilret.c: -------------------------------------------------------------------------------- 1 | /* Copyright U S WEST Advanced Technologies, Inc. 2 | * You may use, copy, modify and sublicense this Software 3 | * subject to the conditions expressed in the file "License". 4 | */ 5 | 6 | #include "apl.h" 7 | #include "utility.h" 8 | #include "data.h" 9 | 10 | /* ex_nilret() is called when a user defined function 11 | * does not return a value. It just puts an empty vector 12 | * onto the expr_stack 13 | */ 14 | 15 | void ex_nilret() 16 | { 17 | checksp(); 18 | *expr_stack_ptr++ = newdat(NIL, 0, 0); 19 | } 20 | -------------------------------------------------------------------------------- /source/userfunc/funread.c: -------------------------------------------------------------------------------- 1 | /* Copyright U S WEST Advanced Technologies, Inc. 2 | * You may use, copy, modify and sublicense this Software 3 | * subject to the conditions expressed in the file "License". 4 | */ 5 | 6 | #include 7 | #include 8 | #include "apl.h" 9 | #include "utility.h" 10 | #include "userfunc.h" 11 | 12 | int funread(char* fname) { 13 | item_t* p; 14 | int f; 15 | 16 | p = expr_stack_ptr[-1]; 17 | expr_stack_ptr--; 18 | 19 | if (p->itemType != LV) { error(ERR_value, "not a local variable"); } 20 | 21 | if (fname == 0) { 22 | fname = ((SymTabEntry*)p)->namep; 23 | } 24 | 25 | f = opn(fname, O_RDONLY); 26 | 27 | fundef(f); 28 | 29 | close(f); 30 | 31 | return f; 32 | } 33 | -------------------------------------------------------------------------------- /source/userfunc/sichk.c: -------------------------------------------------------------------------------- 1 | /* Copyright U S WEST Advanced Technologies, Inc. 2 | * You may use, copy, modify and sublicense this Software 3 | * subject to the conditions expressed in the file "License". 4 | */ 5 | 6 | #include "apl.h" 7 | #include "utility.h" 8 | 9 | void sichk(SymTabEntry* n) { 10 | Context* p; 11 | 12 | p = state_indicator_ptr; 13 | while (p) { 14 | if (n == p->np) 15 | error(ERR, "si damage -- type ')sic'"); 16 | p = p->prev; 17 | } 18 | } 19 | -------------------------------------------------------------------------------- /source/userfunc/tback.c: -------------------------------------------------------------------------------- 1 | /* Copyright U S WEST Advanced Technologies, Inc. 2 | * You may use, copy, modify and sublicense this Software 3 | * subject to the conditions expressed in the file "License". 4 | */ 5 | 6 | #include "apl.h" 7 | 8 | /* 9 | * produce trace back info 10 | */ 11 | 12 | char* atfrom[] = { "at\t", "from\t", "", "" }; 13 | 14 | void tback(int flag) 15 | { 16 | Context* thisContext; 17 | int i; 18 | 19 | if (state_indicator_ptr == &prime_context) 20 | return; /* don't attempt to trace state zero */ 21 | else 22 | thisContext = state_indicator_ptr; 23 | 24 | i = 0; 25 | if (flag) 26 | i = 2; 27 | 28 | while (thisContext != &prime_context) { 29 | if (thisContext->Mode == deffun) { 30 | if (flag == 0 && thisContext->suspended) 31 | return; 32 | if (thisContext->funlc != 1 || i) { /* skip if at line 0 */ 33 | printf("%s%s[%d]%s\n", 34 | atfrom[i], 35 | thisContext->np->namep, 36 | thisContext->funlc - 1, 37 | (thisContext->suspended ? " *" : "")); 38 | i |= 1; 39 | } 40 | } 41 | thisContext = thisContext->prev; 42 | } 43 | } 44 | -------------------------------------------------------------------------------- /source/utility/Makefile: -------------------------------------------------------------------------------- 1 | # Makefile for utility 2 | 3 | include ../include/makefile.common 4 | CFLAGS += -I../include 5 | 6 | OBJECTS = floating.o iodone.o checksp.o fix.o topfix.o \ 7 | errors.o file.o gamma.o signals.o optable.o \ 8 | extend.o map.o scalar.o fappend.o fuzz.o readline.o 9 | 10 | all: Q.o 11 | 12 | Q.o: $(OBJECTS) 13 | $(LD) -r -o Q.o $(OBJECTS) 14 | 15 | $(OBJECTS): ../include/apl.h 16 | 17 | .c.o: 18 | $(CC) $(CFLAGS) -c $< 19 | 20 | clean: 21 | rm -f $(OBJECTS) core 22 | 23 | -------------------------------------------------------------------------------- /source/utility/checksp.c: -------------------------------------------------------------------------------- 1 | /* Copyright U S WEST Advanced Technologies, Inc. 2 | * You may use, copy, modify and sublicense this Software 3 | * subject to the conditions expressed in the file "License". 4 | */ 5 | #include "apl.h" 6 | #include "utility.h" 7 | 8 | void checksp() 9 | { 10 | if (expr_stack_ptr >= &expr_stack[STKS]) 11 | error(ERR, "expr_stack overflow"); 12 | } 13 | -------------------------------------------------------------------------------- /source/utility/extend.c: -------------------------------------------------------------------------------- 1 | /* Copyright U S WEST Advanced Technologies, Inc. 2 | * You may use, copy, modify and sublicense this Software 3 | * subject to the conditions expressed in the file "License". 4 | */ 5 | #include "apl.h" 6 | #include "utility.h" 7 | #include "data.h" 8 | 9 | /* extend - used by ex_base and ex_iprod */ 10 | item_t* 11 | extend(int ty, int n, data d) 12 | { 13 | int i; 14 | item_t* q; 15 | 16 | if (ty != DA) 17 | error(ERR_domain, "not numeric type"); 18 | q = newdat(ty, 1, n); 19 | for (i = 0; i < n; i++) 20 | q->datap[i] = d; 21 | return (q); 22 | } 23 | -------------------------------------------------------------------------------- /source/utility/fappend.c: -------------------------------------------------------------------------------- 1 | /* Copyright U S WEST Advanced Technologies, Inc. 2 | * You may use, copy, modify and sublicense this Software 3 | * subject to the conditions expressed in the file "License". 4 | */ 5 | 6 | #include 7 | #include "apl.h" 8 | #include "data.h" 9 | #include "utility.h" 10 | #include "work_space.h" 11 | 12 | void fappend(int fd, item_t* ap) 13 | { 14 | item_t* p; 15 | char* p1; 16 | int i, dim0, dim1; 17 | char b[200]; 18 | 19 | p = ap; 20 | if (p->rank != 2 && p->rank != 1) 21 | error(ERR_rank, ""); 22 | if (p->itemType != CH) 23 | error(ERR_domain, "not character type"); 24 | dim1 = p->dim[1]; 25 | dim0 = p->dim[0]; 26 | if (p->rank == 1) 27 | dim1 = dim0; 28 | p1 = (char*)(p->datap); 29 | if (p->rank == 2) { 30 | for (i = 0; i < dim0; i++) { 31 | copy(CH, p1, b, dim1); 32 | p1 += dim1; 33 | b[dim1] = '\n'; 34 | writeErrorOnFailure(fd, b, dim1 + 1); 35 | } 36 | } 37 | else 38 | writeErrorOnFailure(fd, p->datap, dim0); 39 | } 40 | -------------------------------------------------------------------------------- /source/utility/file.c: -------------------------------------------------------------------------------- 1 | /* Copyright U S WEST Advanced Technologies, Inc. 2 | * You may use, copy, modify and sublicense this Software 3 | * subject to the conditions expressed in the file "License". 4 | */ 5 | #include 6 | #include 7 | #include 8 | #include 9 | #include 10 | 11 | #include "apl.h" 12 | #include "utility.h" 13 | 14 | static int openOrCreateFile(char* fileName, int mode) 15 | { 16 | int fd; 17 | 18 | if (mode != O_RDONLY && mode != O_WRONLY && mode != O_RDWR) { 19 | fd = creat(fileName, mode); 20 | } 21 | else { 22 | fd = open(fileName, mode); 23 | } 24 | 25 | return fd; 26 | } 27 | 28 | int opn(char file[], int rw) 29 | { 30 | int fd; 31 | char f2[100]; 32 | 33 | if ((fd = openOrCreateFile(file, rw)) < 0) { 34 | strcpy(f2, "/usr/lib/apl/"); 35 | strncat(f2, file, sizeof(f2) - 1); 36 | 37 | if ((fd = openOrCreateFile(f2, rw)) >= 0) { 38 | printf("[using %s]\n", f2); 39 | } 40 | else { 41 | printf("can't open file %s\n", file); 42 | error(ERR, ""); 43 | } 44 | } 45 | return (fd); 46 | } 47 | 48 | int empty(int fd) 49 | { 50 | struct stat sbuf; 51 | 52 | /* Simulate the Rand Corp.'s "empty" system call on a 53 | * V7 system by seeing if the given fd is a pipe, and if 54 | * so, whether or not it is empty. 55 | */ 56 | 57 | if (fstat(fd, &sbuf) < 0) 58 | return (-1); /* Can't "stat" it */ 59 | return (sbuf.st_size == 0); 60 | } 61 | -------------------------------------------------------------------------------- /source/utility/fix.c: -------------------------------------------------------------------------------- 1 | /* Copyright U S WEST Advanced Technologies, Inc. 2 | * You may use, copy, modify and sublicense this Software 3 | * subject to the conditions expressed in the file "License". 4 | */ 5 | #include 6 | #include "apl.h" 7 | 8 | int fix(data d) 9 | { 10 | int i; 11 | 12 | i = floor(d + 0.5); 13 | return (i); 14 | } 15 | -------------------------------------------------------------------------------- /source/utility/floating.c: -------------------------------------------------------------------------------- 1 | /* Copyright U S WEST Advanced Technologies, Inc. 2 | * You may use, copy, modify and sublicense this Software 3 | * subject to the conditions expressed in the file "License". 4 | */ 5 | 6 | /* 7 | * Floating-point initialization and trap service 8 | * 9 | */ 10 | 11 | #include 12 | #include "apl.h" 13 | #include "utility.h" 14 | 15 | char* fpelist[] = { 16 | "floating exception", 17 | "integer overflow", 18 | "integer divide by zero", 19 | "floating overflow", 20 | "floating divide by zero", 21 | "floating underflow", 22 | "decimal overflow", 23 | "subscript range", 24 | "floating overflow", 25 | "floating divide by zero", 26 | "floating underflow" 27 | }; 28 | 29 | void fpe(int param) 30 | { 31 | signal(SIGFPE, fpe); 32 | if (param >= sizeof fpelist / sizeof fpelist[0]) 33 | error(ERR, "floating exception"); 34 | else 35 | error(ERR, fpelist[param]); 36 | } 37 | 38 | void fppinit(int arg) 39 | { 40 | signal(SIGFPE, fpe); 41 | } 42 | -------------------------------------------------------------------------------- /source/utility/fuzz.c: -------------------------------------------------------------------------------- 1 | /* Copyright U S WEST Advanced Technologies, Inc. 2 | * You may use, copy, modify and sublicense this Software 3 | * subject to the conditions expressed in the file "License". 4 | */ 5 | #include "apl.h" 6 | 7 | int fuzz(data d1, data d2) 8 | { 9 | data f1, f2; 10 | 11 | f1 = d1; 12 | if (f1 < 0.) 13 | f1 = -f1; 14 | f2 = d2; 15 | if (f2 < 0.) 16 | f2 = -f2; 17 | if (f2 > f1) 18 | f1 = f2; 19 | f1 *= tolerance; 20 | if (d1 > d2) { 21 | if (d2 + f1 >= d1) 22 | return (0); 23 | return (1); 24 | } 25 | if (d1 + f1 >= d2) 26 | return (0); 27 | return (-1); 28 | } 29 | -------------------------------------------------------------------------------- /source/utility/iodone.c: -------------------------------------------------------------------------------- 1 | /* Copyright U S WEST Advanced Technologies, Inc. 2 | * You may use, copy, modify and sublicense this Software 3 | * subject to the conditions expressed in the file "License". 4 | */ 5 | 6 | #include "apl.h" 7 | #include "data.h" 8 | 9 | void iodone(int ok) 10 | { 11 | item_t* p; 12 | 13 | p = newdat(DA, 0, 1); 14 | p->datap[0] = ok; 15 | *expr_stack_ptr++ = p; 16 | } 17 | -------------------------------------------------------------------------------- /source/utility/map.c: -------------------------------------------------------------------------------- 1 | /* Copyright U S WEST Advanced Technologies, Inc. 2 | * You may use, copy, modify and sublicense this Software 3 | * subject to the conditions expressed in the file "License". 4 | */ 5 | #include "apl.h" 6 | #include "data.h" 7 | 8 | /* map used by ex_take ex_drop, ex_rev* and trn0 9 | * which is used by ex_dtrn and ex_mtrn 10 | */ 11 | 12 | void map(int o) { 13 | item_t* p; 14 | int n, i; 15 | 16 | n = 1; 17 | 18 | for (i = 0; i < idx.rank; i++) 19 | n *= idx.dim[i]; 20 | 21 | p = newdat(idx.type, idx.rank, n); 22 | 23 | copy(IN, (char*)idx.dim, (char*)p->dim, idx.rank); 24 | *expr_stack_ptr++ = p; 25 | 26 | if (n != 0) { 27 | item_t* p = expr_stack_ptr[-2]; 28 | 29 | indexIterateInit(&idx); 30 | while (indexIterate(&idx)) { 31 | p->index = access() + o; 32 | putdat(expr_stack_ptr[-1], getdat(p)); 33 | } 34 | } 35 | 36 | expr_stack_ptr--; 37 | pop(); 38 | *expr_stack_ptr++ = p; 39 | } 40 | -------------------------------------------------------------------------------- /source/utility/scalar.c: -------------------------------------------------------------------------------- 1 | /* Copyright U S WEST Advanced Technologies, Inc. 2 | * You may use, copy, modify and sublicense this Software 3 | * subject to the conditions expressed in the file "License". 4 | */ 5 | #include "apl.h" 6 | 7 | /* 8 | * scalar -- return true if arg is a scalar 9 | */ 10 | int scalar(item_t* aip) 11 | { 12 | return (aip->size == 1); 13 | } 14 | -------------------------------------------------------------------------------- /source/utility/topfix.c: -------------------------------------------------------------------------------- 1 | /* Copyright U S WEST Advanced Technologies, Inc. 2 | * You may use, copy, modify and sublicense this Software 3 | * subject to the conditions expressed in the file "License". 4 | */ 5 | #include "apl.h" 6 | #include "utility.h" 7 | #include "data.h" 8 | 9 | int topfix() 10 | { 11 | item_t* p; 12 | int i; 13 | 14 | p = fetch1(); 15 | 16 | if (p->itemType != DA) 17 | error(ERR_domain, "topval"); 18 | 19 | if (p->size != 1) 20 | error(ERR_length, "topval"); 21 | 22 | i = fix(p->datap[0]); 23 | 24 | pop(); 25 | 26 | return (i); 27 | } 28 | -------------------------------------------------------------------------------- /source/work_space/Makefile: -------------------------------------------------------------------------------- 1 | # Makefile for APL11 2 | 3 | include ../include/makefile.common 4 | CFLAGS += -I../include 5 | 6 | OBJECTS = ws_clear.o ws_load.o ws_save.o fdat.o 7 | 8 | all: Q.o 9 | 10 | Q.o: $(OBJECTS) 11 | $(LD) -r -o Q.o $(OBJECTS) 12 | 13 | $(OBJECTS): ../include/apl.h 14 | 15 | .c.o: 16 | $(CC) $(CFLAGS) -c $< 17 | 18 | clean: 19 | rm -f $(OBJECTS) core 20 | 21 | -------------------------------------------------------------------------------- /source/work_space/fdat.c: -------------------------------------------------------------------------------- 1 | /* openAPL, Copyright (C) Branko Bratkovic 2000 2 | * This file is free software and is covered by the GNU General 3 | * Public License. 4 | * 5 | * This program is distributed in the hope that it will be useful, 6 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 7 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. 8 | * 9 | * For more details see the GNU General Public License (GPL) in 10 | * the docs directory. 11 | */ 12 | 13 | #include "apl.h" 14 | 15 | void fdat(int f) 16 | { 17 | struct stat b; 18 | struct tm *p, *localtime(); 19 | 20 | fstat(f, &b); 21 | p = localtime(&b.st_mtime); 22 | 23 | printf(" %02d:%02d.%02d", p->tm_hour, p->tm_min, p->tm_sec); 24 | printf(" %02d/%02d/%02d", p->tm_mon + 1, p->tm_mday, p->tm_year % 100); 25 | } 26 | -------------------------------------------------------------------------------- /source/work_space/fdat.h: -------------------------------------------------------------------------------- 1 | /* fdat.h, Copyright (C) 2016, Greg Johnson 2 | * Released under the terms of the GNU GPL v2.0. 3 | * 4 | * This program is distributed in the hope that it will be useful, 5 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 6 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 7 | * GNU General Public License for more details. 8 | */ 9 | #ifndef FDAT_H 10 | #define FDAT_H 11 | 12 | void fdat(int f); 13 | 14 | #endif 15 | -------------------------------------------------------------------------------- /source/work_space/ws_clear.c: -------------------------------------------------------------------------------- 1 | /* Copyright U S WEST Advanced Technologies, Inc. 2 | * You may use, copy, modify and sublicense this Software 3 | * subject to the conditions expressed in the file "License". 4 | */ 5 | #include "apl.h" 6 | #include "memory.h" 7 | #include "data.h" 8 | 9 | void clear() 10 | { 11 | symtab_clear(); 12 | 13 | afreset(); /* release all dynamic memory */ 14 | state_indicator_ptr = 0; /* reset state indicator */ 15 | 16 | iorigin = INITIAL_iorigin; 17 | pagewidth = INITIAL_pagewidth; 18 | PrintP = INITIAL_PrintP; 19 | tolerance = INITIAL_tolerance; 20 | } 21 | --------------------------------------------------------------------------------