├── .github └── workflows │ └── c-cpp.yml ├── .gitignore ├── LICENSE ├── README.md ├── agglib.joy ├── fib.joy ├── globals.h ├── inilib.joy ├── interp.c ├── joy.vim ├── main.c ├── makefile ├── scan.c ├── test2 ├── __dump.joy ├── __latex_manual.joy ├── __memoryindex.joy ├── __memorymax.joy ├── __settracegc.joy ├── __symtabindex.joy ├── __symtabmax.joy ├── _help.joy ├── abort.joy ├── abs.joy ├── add.joy ├── all.joy ├── and.joy ├── app1.joy ├── app11.joy ├── app12.joy ├── app2.joy ├── app3.joy ├── app4.joy ├── at.joy ├── autoput.joy ├── binary.joy ├── binrec.joy ├── body.joy ├── branch.joy ├── char.joy ├── choice.joy ├── cleave.joy ├── clock.joy ├── compare.joy ├── concat.joy ├── cond.joy ├── condlinrec.joy ├── cons.joy ├── construct.joy ├── conts.joy ├── dip.joy ├── divide.joy ├── drop.joy ├── dup.joy ├── dupd.joy ├── echo.joy ├── eql.joy ├── equal.joy ├── false.joy ├── filter.joy ├── first.joy ├── fold.joy ├── gc.joy ├── genrec.joy ├── geql.joy ├── get.joy ├── greater.joy ├── has.joy ├── help.joy ├── helpdetail.joy ├── i.joy ├── id.joy ├── ifchar.joy ├── ifinteger.joy ├── iflist.joy ├── iflogical.joy ├── ifset.joy ├── ifstring.joy ├── ifte.joy ├── in.joy ├── include.joy ├── infra.joy ├── integer.joy ├── leaf.joy ├── leql.joy ├── less.joy ├── linrec.joy ├── list.joy ├── logical.joy ├── manual.joy ├── map.joy ├── max.joy ├── maxint.joy ├── min.joy ├── mul.joy ├── name.joy ├── neql.joy ├── not.joy ├── null.joy ├── nullary.joy ├── of.joy ├── opcase.joy ├── or.joy ├── pop.joy ├── popd.joy ├── pred.joy ├── primrec.joy ├── put.joy ├── putch.joy ├── quit.joy ├── rem.joy ├── rest.joy ├── rolldown.joy ├── rolldownd.joy ├── rollup.joy ├── rollupd.joy ├── rotate.joy ├── rotated.joy ├── set.joy ├── setautoput.joy ├── setecho.joy ├── setsize.joy ├── sign.joy ├── size.joy ├── small.joy ├── some.joy ├── split.joy ├── stack.joy ├── step.joy ├── string.joy ├── sub.joy ├── succ.joy ├── swap.joy ├── swapd.joy ├── swons.joy ├── system.joy ├── tailrec.joy ├── take.joy ├── ternary.joy ├── times.joy ├── treegenrec.joy ├── treerec.joy ├── treestep.joy ├── true.joy ├── unary.joy ├── uncons.joy ├── unstack.joy ├── unswons.joy ├── user.joy ├── while.joy ├── x.joy └── xor.joy ├── usrlib.joy └── utils.c /.github/workflows/c-cpp.yml: -------------------------------------------------------------------------------- 1 | name: C/C++ CI 2 | 3 | on: 4 | push: 5 | branches: [ "main" ] 6 | pull_request: 7 | branches: [ "main" ] 8 | 9 | workflow_dispatch: 10 | 11 | jobs: 12 | build: 13 | 14 | runs-on: ubuntu-latest 15 | 16 | steps: 17 | - uses: actions/checkout@v3 18 | # - name: configure 19 | # run: ./configure 20 | - name: make 21 | run: make 22 | # - name: make check 23 | # run: make check 24 | # - name: make distcheck 25 | # run: make distcheck 26 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | *.tar 2 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | This is free and unencumbered software released into the public domain. 2 | 3 | Anyone is free to copy, modify, publish, use, compile, sell, or 4 | distribute this software, either in source code form or as a compiled 5 | binary, for any purpose, commercial or non-commercial, and by any 6 | means. 7 | 8 | In jurisdictions that recognize copyright laws, the author or authors 9 | of this software dedicate any and all copyright interest in the 10 | software to the public domain. We make this dedication for the benefit 11 | of the public at large and to the detriment of our heirs and 12 | successors. We intend this dedication to be an overt act of 13 | relinquishment in perpetuity of all present and future rights to this 14 | software under copyright law. 15 | 16 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 17 | EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 18 | MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. 19 | IN NO EVENT SHALL THE AUTHORS BE LIABLE FOR ANY CLAIM, DAMAGES OR 20 | OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, 21 | ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR 22 | OTHER DEALINGS IN THE SOFTWARE. 23 | 24 | For more information, please refer to 25 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | Joy0 2 | ---- 3 | 4 | This is the original version of [Joy](https://github.com/Wodan58/Joy), 5 | created by Manfred von Thun. It is kept as a reference implementation 6 | in order to make sure that other implementations don't deviate too much 7 | from this one. 8 | 9 | Changes 10 | ------- 11 | 12 | Some system header files have been added. Functions declarations have been 13 | ANSIfied, allowing compilation with all warnings turned on. 14 | 15 | The return value of newnode needs to be captured in a variable. 16 | This introduces a sequence point, preventing unspecified behaviour. 17 | TRACING was used to locate the problem, so it was kept in the source code. 18 | CORRECT\_GARBAGE\_COLLECTOR prints a runtime error in case of memory overflow. 19 | 20 | Warning 21 | ------- 22 | 23 | The source code assumes that sizeof(long) == sizeof(void *). 24 | 25 | Build 26 | ----- 27 | 28 | make 29 | 30 | Test 31 | ---- 32 | 33 | cd test2 34 | for i in *.joy 35 | do 36 | ../joy $i >$i.out 37 | done 38 | grep -l false *.out 39 | -------------------------------------------------------------------------------- /agglib.joy: -------------------------------------------------------------------------------- 1 | (* FILE: agglib.joy *) 2 | 3 | LIBRA 4 | 5 | _agglib == true; 6 | 7 | (* - - - - - O P E R A T O R S - - - - - *) 8 | 9 | unitset == {} cons; 10 | unitstring == "" cons; 11 | unitlist == [] cons; 12 | pairset == {} cons cons; 13 | pairstring == "" cons cons; 14 | pairlist == [] cons cons; 15 | unpair == uncons uncons pop; 16 | second == rest first; 17 | third == rest rest first; 18 | fourth == 3 drop first; 19 | fifth == 4 drop first; 20 | string2set == {} swap shunt; 21 | elements == {} swap [swons] step; 22 | (* 23 | set2string == "" swap [chr swons] step; 24 | *) 25 | set2string == "" [[chr] dip cons] foldr; 26 | shunt == [swons] step; 27 | 28 | (* "dipped" versions *) 29 | 30 | nulld == [null] dip; 31 | consd == [cons] dip; 32 | swonsd == [swons] dip; 33 | unconsd == [uncons] dip; 34 | unswonsd == [unswons] dip; 35 | firstd == [first] dip; 36 | restd == [rest] dip; 37 | secondd == [second] dip; (* R.W. *) 38 | thirdd == [third] dip; 39 | 40 | (* on two operands *) 41 | 42 | null2 == nulld null or; 43 | cons2 == swapd cons consd; 44 | uncons2 == unconsd uncons swapd; 45 | swons2 == swapd swons swonsd; 46 | unswons2 == [unswons] dip unswons swapd; 47 | 48 | zip == [null2] [pop2 []] [uncons2] [[pairlist] dip cons] linrec; 49 | 50 | from-to == (* lo hi agg *) 51 | [] cons [pop pop] swoncat 52 | [>] swap 53 | [ [dup succ] dip ] 54 | [cons] 55 | linrec; 56 | from-to-list == [] from-to; 57 | from-to-set == {} from-to; 58 | from-to-string == "" from-to; 59 | 60 | (* - - - - - C O M B I N A T O R S - - - - - *) 61 | 62 | (* Left to Right *) 63 | 64 | (* inbuilt: step map fold filter split *) 65 | (* desirable: step2 map2 fold2 *) 66 | 67 | (* cartesian product -like *) 68 | pairstep == [dupd] swoncat [step pop] cons cons step; 69 | 70 | (* Right to Left *) 71 | 72 | mapr == 73 | [ [null] [] [uncons] ] dip (* P1 P2 P3 *) 74 | [dip cons] cons (* P4 *) 75 | linrec; 76 | foldr == 77 | [ [ [null] ] dip (* P1 *) 78 | [] cons [pop] swoncat (* P2 *) 79 | [uncons] ] dip (* P3 *) 80 | linrec; 81 | 82 | stepr2 == 83 | [ [null2] [pop pop] ] dip (* P1 P2 *) 84 | [dip] cons [dip] cons [uncons2] swoncat (* P3 *) 85 | tailrec; 86 | fold2 == rollupd stepr2; 87 | 88 | mapr2 == (* == zipwith B&W p 57 *) 89 | [ [null2] [pop2 []] [uncons2] ] dip (* P1 P2 P3 *) 90 | [dip cons] cons (* P4 *) 91 | linrec; 92 | foldr2 == 93 | [ [ [null2] ] dip (* P1 *) 94 | [] cons [pop2] swoncat (* P2 *) 95 | [uncons2] ] dip (* P3 *) 96 | linrec; 97 | interleave2 == [cons cons] foldr2; 98 | interleave2list == [] interleave2; 99 | 100 | sum == 0 [+] fold; 101 | average == [sum] [size] cleave / ; 102 | variance == (* [..] variance *) 103 | 0 swap dup (* 0.0 [..] [..] *) 104 | [sum] [size] cleave dup (* 0.0 [..] su n n *) 105 | [ / (* 0.0 [..] av n *) 106 | [ - dup * + ] cons (* 0.0 [..] [av - dup * +] n *) 107 | step ] (* sumsq n *) 108 | dip 109 | pred / ; 110 | 111 | AGGLIB == "agglib.joy - aggregate library\n". 112 | (* end LIBRA *) 113 | 114 | "agglib is loaded\n" putchars. 115 | 116 | (* END agglib.joy *) 117 | -------------------------------------------------------------------------------- /fib.joy: -------------------------------------------------------------------------------- 1 | 0 __settracegc. 2 | 35 [small] [] [pred dup pred] [+] binrec. 3 | -------------------------------------------------------------------------------- /globals.h: -------------------------------------------------------------------------------- 1 | /* 2 | module : globals.h 3 | version : 1.1.1.1 4 | date : 09/13/23 5 | */ 6 | /* FILE : globals.h */ 7 | 8 | #define SHELLESCAPE '$' 9 | #define INPSTACKMAX 10 10 | #define INPLINEMAX 80 11 | #define ALEN 20 12 | #define HASHSIZE 9 13 | #define SYMTABMAX 2000 14 | #define MEMORYMAX 100000 15 | #define INIECHOFLAG 0 16 | #define INIAUTOPUT 1 17 | #define INITRACEGC 1 18 | /* installation dependent */ 19 | #define SETSIZE 32 20 | #define MAXINT 2147483647 21 | /* symbols from getsym */ 22 | #define ILLEGAL_ 0 23 | #define COPIED_ 1 24 | #define USR_ 2 25 | #define ANON_FUNCT_ 3 26 | #define BOOLEAN_ 4 27 | #define CHAR_ 5 28 | #define INTEGER_ 6 29 | #define SET_ 7 30 | #define STRING_ 8 31 | #define LIST_ 9 32 | #define LBRACK 900 33 | #define LBRACE 901 34 | #define LPAREN 902 35 | #define ATOM 999 /* last legal factor begin */ 36 | #define RBRACK 1001 37 | #define RPAREN 1003 38 | #define RBRACE 1005 39 | #define PERIOD 1006 40 | #define SEMICOL 1007 41 | #define LIBRA 1100 42 | #define EQDEF 1101 43 | #define HIDE 1102 44 | #define IN 1103 45 | #define END 1104 46 | 47 | #ifdef DEBUG 48 | # define D(x) x 49 | #else 50 | # define D(x) 51 | #endif 52 | 53 | #define PRIVATE static 54 | #define PUBLIC 55 | 56 | /* types */ 57 | typedef int Symbol; 58 | typedef short Operator; 59 | 60 | typedef struct Node 61 | { Operator op; 62 | union 63 | { long num; 64 | long set; 65 | char *str; 66 | struct Node *lis; 67 | struct Entry *ent; 68 | void (*proc)(); } u; 69 | struct Node *next; } Node; 70 | typedef struct Entry 71 | { char *name; 72 | union 73 | { Node *body; 74 | void (*proc) (); } u; 75 | struct Entry *next; } Entry; 76 | 77 | #ifdef ALLOC 78 | # define CLASS 79 | #else 80 | # define CLASS extern 81 | #endif 82 | 83 | CLASS int echoflag; 84 | CLASS int autoput; 85 | CLASS int tracegc; 86 | CLASS int startclock,gc_clock; /* main */ 87 | CLASS char ch; /* scanner */ 88 | CLASS Symbol sym; 89 | CLASS long num; 90 | CLASS char id[ALEN]; 91 | CLASS int hashvalue; 92 | 93 | CLASS Entry /* symbol table */ 94 | symtab[SYMTABMAX], 95 | *hashentry[HASHSIZE], 96 | *localentry, 97 | *symtabindex, 98 | *firstlibra, /* inioptable */ 99 | *location; /* getsym */ 100 | 101 | #define LOC2INT(e) (((long)e - (long)symtab) / sizeof(Entry)) 102 | #define INT2LOC(x) ((Entry*) ((x + (long)symtab)) * sizeof(Entry)) 103 | 104 | CLASS Node /* dynamic memory */ 105 | /* 106 | memory[MEMORYMAX], 107 | *memoryindex, 108 | */ 109 | *prog, *stk, *conts, 110 | *dump, *dump1, *dump2, *dump3, *dump4, *dump5; 111 | 112 | #define MEM2INT(n) (((long)n - (long)memory) / (long)sizeof(Node)) 113 | #define INT2MEM(x) ((Node *) ((x + (long)&memory) * (long)sizeof(Node))) 114 | 115 | /* GOOD REFS: 116 | 005.133l H4732 A LISP interpreter in C 117 | Manna p139 recursive Ackermann SCHEMA 118 | 119 | OTHER DATA TYPES 120 | WORD = "ABCD" - up to four chars 121 | LIST of SETs of char [S0 S1 S2 S3] 122 | LISTS - binary tree [left right] 123 | " with info [info left right] 124 | STRING of 32 chars = 32 * 8 bits = 256 bits = bigset 125 | CHAR = 2 HEX 126 | 32 SET = 2 * 16SET 127 | */ 128 | -------------------------------------------------------------------------------- /inilib.joy: -------------------------------------------------------------------------------- 1 | (* FILE: inilib.joy *) 2 | 3 | LIBRA 4 | 5 | _inilib == true; 6 | 7 | 8 | (* - - - - - I N P U T O U T P U T - - - - *) 9 | 10 | newline == '\n putch; 11 | putln == put newline; 12 | space == '\032 putch; 13 | bell == '\007 putch; 14 | (* this is now a primitive in raw Joy: 15 | putchars == [putch] step; 16 | *) 17 | putstrings == [putchars] step; 18 | 19 | ask == "Please " putchars putchars newline get; 20 | 21 | (* - - - - - O P E R A T O R S - - - - - *) 22 | 23 | dup2 == dupd dup swapd; 24 | pop2 == pop pop; 25 | newstack == [] unstack; 26 | truth == true; 27 | falsity == false; 28 | to-upper == ['a >=] [32 -] [] ifte; 29 | to-lower == ['a < ] [32 +] [] ifte; 30 | boolean == [logical] [set] sequor; 31 | numerical == [integer] [float] sequor; 32 | swoncat == swap concat; 33 | 34 | (* date and time *) 35 | 36 | weekdays == 37 | [ "Monday" "Tuesday" "Wednesday" "Thursday" "Friday" 38 | "Saturday" "Sunday" ]; 39 | months == 40 | [ "JAN" "FEB" "MAR" "APR" "MAY" "JUN" 41 | "JUL" "AUG" "SEP" "OCT" "NOV" "DEC" ]; 42 | localtime-strings == 43 | time localtime 44 | [ [ 0 at 'd 4 4 format ] 45 | [ 1 at pred months of ] 46 | [ 2 at 'd 2 2 format ] 47 | [ 3 at 'd 2 2 format ] 48 | [ 4 at 'd 2 2 format ] 49 | [ 5 at 'd 2 2 format ] 50 | [ 6 at [] ["true"] ["false"] ifte ] 51 | [ 7 at 'd 5 5 format ] 52 | [ 8 at pred weekdays of ] ] 53 | [i] map 54 | popd; 55 | today == 56 | localtime-strings 57 | [ [8 at] [" "] [2 at] ["-"] [1 at] ["-"] [0 at rest rest] ] 58 | [i] map 59 | popd 60 | "" [concat] fold; 61 | now == 62 | localtime-strings 63 | 3 drop 64 | [ [0 at] [":"] [1 at] [":"] [2 at] ] 65 | [i] map 66 | popd 67 | "" [concat] fold; 68 | show-todaynow == 69 | today putchars space now putchars newline; 70 | 71 | (* program operators *) 72 | 73 | conjoin == [[false] ifte] cons cons; 74 | disjoin == [ifte] cons [true] swons cons; 75 | negate == [[false] [true] ifte] cons; 76 | 77 | (* - - - - - C O M B I N A T O R S - - - - - *) 78 | 79 | sequor == [pop true] swap ifte; 80 | sequand == [pop false] ifte; 81 | dipd == [dip] cons dip; 82 | dip2 == [dip] cons dip; 83 | dip3 == [dip2] cons dip; 84 | call == [] cons i; 85 | i2 == [dip] dip i; 86 | nullary2 == [nullary] cons dup i2 swapd; 87 | (* this is now a primitive in raw Joy: 88 | unary2 == [unary ] cons dup i2; 89 | *) 90 | repeat == dupd swap [i] dip2 while; 91 | forever == maxint swap times; 92 | 93 | (* library inclusion *) 94 | 95 | verbose == false; 96 | libload == 97 | [ '_ swons intern body null ] 98 | [ ".joy" concat include ] 99 | [ [ verbose ] 100 | [ putchars " is already loaded\n" putchars ] 101 | [ pop ] 102 | ifte ] 103 | ifte; 104 | basic-libload == 105 | "agglib" libload 106 | "seqlib" libload 107 | "numlib" libload; 108 | special-libload == 109 | "mtrlib" libload 110 | "tutlib" libload 111 | "lazlib" libload 112 | "lsplib" libload 113 | "symlib" libload; 114 | 115 | all-libload == basic-libload special-libload; 116 | 117 | INILIB == "inilib.joy - the initial library, assumed everywhere\n". 118 | (* end LIBRA *) 119 | 120 | "inilib is loaded\n" putchars. 121 | 122 | (* END inilib.joy *) 123 | -------------------------------------------------------------------------------- /interp.c: -------------------------------------------------------------------------------- 1 | /* 2 | module : interp.c 3 | version : 1.1.1.3 4 | date : 12/16/24 5 | */ 6 | /* FILE: interp.c */ 7 | 8 | #include 9 | #include 10 | #include 11 | #include 12 | #include "globals.h" 13 | 14 | /* #define TRACING */ 15 | 16 | PUBLIC void printnode(Node *p); /* file utils.c */ 17 | 18 | PRIVATE void helpdetail_(); /* this file */ 19 | PRIVATE void make_manual(int latex); 20 | PUBLIC char *opername(int o); 21 | 22 | #define ONEPARAM(NAME) \ 23 | if (stk == NULL) \ 24 | execerror("one parameter",NAME) 25 | #define TWOPARAMS(NAME) \ 26 | if (stk == NULL || stk->next == NULL) \ 27 | execerror("two parameters",NAME) 28 | #define THREEPARAMS(NAME) \ 29 | if (stk == NULL || stk->next == NULL \ 30 | || stk->next->next == NULL) \ 31 | execerror("three parameters",NAME) 32 | #define FOURPARAMS(NAME) \ 33 | if (stk == NULL || stk->next == NULL \ 34 | || stk->next->next == NULL \ 35 | || stk->next->next->next == NULL) \ 36 | execerror("four parameters",NAME) 37 | #define FIVEPARAMS(NAME) \ 38 | if (stk == NULL || stk->next == NULL \ 39 | || stk->next->next == NULL \ 40 | || stk->next->next->next == NULL \ 41 | || stk->next->next->next->next == NULL) \ 42 | execerror("five parameters",NAME) 43 | #define ONEQUOTE(NAME) \ 44 | if (stk->op != LIST_) \ 45 | execerror("quotation as top parameter",NAME) 46 | #define TWOQUOTES(NAME) \ 47 | ONEQUOTE(NAME); \ 48 | if (stk->next->op != LIST_) \ 49 | execerror("quotation as second parameter",NAME) 50 | #define THREEQUOTES(NAME) \ 51 | TWOQUOTES(NAME); \ 52 | if (stk->next->next->op != LIST_) \ 53 | execerror("quotation as third parameter",NAME) 54 | #define FOURQUOTES(NAME) \ 55 | THREEQUOTES(NAME); \ 56 | if (stk->next->next->next->op != LIST_) \ 57 | execerror("quotation as fourth parameter",NAME) 58 | #define FIVEQUOTES(NAME) \ 59 | FOURQUOTES(NAME); \ 60 | if (stk->next->next->next->next->op != LIST_) \ 61 | execerror("quotation as fifth parameter",NAME) 62 | #define SAME2TYPES(NAME) \ 63 | if (stk->op != stk->next->op) \ 64 | execerror("two parameters of the same type",NAME) 65 | #define STRING(NAME) \ 66 | if (stk->op != STRING_) \ 67 | execerror("string",NAME) 68 | #define INTEGER(NAME) \ 69 | if (stk->op != INTEGER_) \ 70 | execerror("integer",NAME) 71 | #define INTEGERS2(NAME) \ 72 | if (stk->op != INTEGER_ || stk->next->op != INTEGER_) \ 73 | execerror("two integers",NAME) 74 | #define NUMERICTYPE(NAME) \ 75 | if (stk->op != INTEGER_ && stk->op != CHAR_) \ 76 | execerror("numeric",NAME) 77 | #define NUMERIC2(NAME) \ 78 | if (stk->next->op != INTEGER_ && stk->next->op != CHAR_) \ 79 | execerror("numeric second parameter",NAME) 80 | #define CHECKZERO(NAME) \ 81 | if (stk->u.num == 0) \ 82 | execerror("non-zero operand",NAME) 83 | #define LIST(NAME) \ 84 | if (stk->op != LIST_) \ 85 | execerror("list",NAME) 86 | #define LIST2(NAME) \ 87 | if (stk->next->op != LIST_) \ 88 | execerror("list as second parameter",NAME) 89 | #define USERDEF(NAME) \ 90 | if (stk->op != USR_) \ 91 | execerror("user defined symbol",NAME) 92 | #define CHECKLIST(OPR,NAME) \ 93 | if (OPR != LIST_) \ 94 | execerror("internal list",NAME) 95 | #define CHECKSETMEMBER(NODE,NAME) \ 96 | if ((NODE->op != INTEGER_ && NODE->op != CHAR_) || \ 97 | NODE->u.num >= SETSIZE) \ 98 | execerror("small numeric",NAME) 99 | #define CHECKEMPTYSET(SET,NAME) \ 100 | if (SET == 0) \ 101 | execerror("non-empty set",NAME) 102 | #define CHECKEMPTYSTRING(STRING,NAME) \ 103 | if (*STRING == '\0') \ 104 | execerror("non-empty string",NAME) 105 | #define CHECKEMPTYLIST(LIST,NAME) \ 106 | if (LIST == NULL) \ 107 | execerror("non-empty list",NAME) 108 | #define INDEXTOOLARGE(NAME) \ 109 | execerror("smaller index",NAME) 110 | #define BADAGGREGATE(NAME) \ 111 | execerror("aggregate parameter",NAME) 112 | #define BADDATA(NAME) \ 113 | do { execerror("different type",NAME); break; } while (0) 114 | 115 | #define DMP dump->u.lis 116 | #define DMP1 dump1->u.lis 117 | #define DMP2 dump2->u.lis 118 | #define DMP3 dump3->u.lis 119 | #define DMP4 dump4->u.lis 120 | #define DMP5 dump5->u.lis 121 | #define SAVESTACK dump = newnode(LIST_,stk,dump) 122 | #define SAVED1 DMP 123 | #define SAVED2 DMP->next 124 | #define SAVED3 DMP->next->next 125 | #define SAVED4 DMP->next->next->next 126 | #define SAVED5 DMP->next->next->next->next 127 | #define SAVED6 DMP->next->next->next->next->next 128 | 129 | #define POP(X) X = X->next 130 | 131 | #define NULLARY(TYPE,VALUE) \ 132 | stk = newnode(TYPE,VALUE,stk) 133 | #define UNARY(TYPE,VALUE) \ 134 | stk = newnode(TYPE,VALUE,stk->next) 135 | #define BINARY(TYPE,VALUE) \ 136 | stk = newnode(TYPE,VALUE,stk->next->next) 137 | #define TERNARY(TYPE,VALUE) \ 138 | stk = newnode(TYPE,VALUE,stk->next->next->next) 139 | 140 | #define GETSTRING(NODE) \ 141 | ( NODE->op == STRING_ ? NODE->u.str : \ 142 | (NODE->op == USR_ ? NODE->u.ent->name : \ 143 | opername(NODE->op) ) ) 144 | 145 | /* PUBLIC int clock(); */ /* file time.h */ 146 | PUBLIC Node *newnode(Operator o, long l, Node *r); /* file utils.c */ 147 | PUBLIC void memoryindex_(); 148 | PUBLIC void execerror(char *message, char *op); /* file main.c */ 149 | PUBLIC void abortexecution_(); 150 | PUBLIC void getsym(); /* file scan.c */ 151 | PUBLIC void doinclude(char *filnam); 152 | PUBLIC void readfactor(); /* file utils.c */ 153 | PUBLIC void writefactor(Node *n); 154 | PUBLIC void writeterm(Node *n); 155 | PUBLIC void quit_(); 156 | PUBLIC void gc_(); 157 | /* PUBLIC int malloc(); */ /* in the library */ 158 | /* PUBLIC void system(); */ 159 | 160 | /* - - - - O P E R A N D S - - - - */ 161 | 162 | #define PUSH(PROCEDURE,TYPE,VALUE) \ 163 | PRIVATE void PROCEDURE() \ 164 | { NULLARY(TYPE,VALUE); } 165 | PUSH(true_,BOOLEAN_,1) /* constants */ 166 | PUSH(false_,BOOLEAN_,0) 167 | PUSH(setsize_,INTEGER_,SETSIZE) 168 | PUSH(maxint_,INTEGER_,MAXINT) 169 | PUSH(symtabmax_,INTEGER_,SYMTABMAX) 170 | PUSH(memorymax_,INTEGER_,MEMORYMAX) 171 | PUSH(stack_,LIST_,stk) /* variables */ 172 | PUSH(dump_,LIST_,dump) 173 | PUSH(conts_,LIST_,newnode(LIST_,conts->u.lis->next,conts->next)) 174 | PUSH(symtabindex_,INTEGER_,LOC2INT(symtabindex)) 175 | /* this is now in utils.c 176 | PUSH(memoryindex_,INTEGER_,MEM2INT(memoryindex)) 177 | */ 178 | PUSH(echo_,INTEGER_,echoflag) 179 | PUSH(autoput_,INTEGER_,autoput) 180 | PUSH(clock_,INTEGER_,clock() - startclock) 181 | 182 | /* - - - - - O P E R A T O R S - - - - - */ 183 | 184 | PRIVATE void id_() 185 | { 186 | /* do nothing */ 187 | } 188 | PRIVATE void unstack_() 189 | { 190 | ONEPARAM("unstack"); 191 | LIST("unstack"); 192 | stk = stk->u.lis; 193 | } 194 | /* 195 | PRIVATE void newstack_() 196 | { 197 | stk = NULL; 198 | } 199 | */ 200 | 201 | /* - - - STACK - - - */ 202 | 203 | PRIVATE void name_() 204 | { 205 | ONEPARAM("name"); 206 | UNARY(STRING_, stk->op == USR_ ? 207 | stk->u.ent->name : opername(stk->op)); 208 | } 209 | PRIVATE void body_() 210 | { 211 | ONEPARAM("body"); 212 | USERDEF("body"); 213 | UNARY(LIST_,stk->u.ent->u.body); 214 | } 215 | PRIVATE void pop_() 216 | { 217 | ONEPARAM("pop"); 218 | POP(stk); 219 | } 220 | PRIVATE void swap_() 221 | { 222 | TWOPARAMS("swap"); 223 | SAVESTACK; 224 | BINARY(SAVED1->op,SAVED1->u.num); 225 | NULLARY(SAVED2->op,SAVED2->u.num); 226 | POP(dump); 227 | } 228 | PRIVATE void rollup_() 229 | { 230 | THREEPARAMS("rollup"); 231 | SAVESTACK; 232 | TERNARY(SAVED1->op,SAVED1->u.num); 233 | NULLARY(SAVED3->op,SAVED3->u.num); 234 | NULLARY(SAVED2->op,SAVED2->u.num); 235 | POP(dump); 236 | } 237 | PRIVATE void rolldown_() 238 | { 239 | THREEPARAMS("rolldown"); 240 | SAVESTACK; 241 | TERNARY(SAVED2->op,SAVED2->u.num); 242 | NULLARY(SAVED1->op,SAVED1->u.num); 243 | NULLARY(SAVED3->op,SAVED3->u.num); 244 | POP(dump); 245 | } 246 | PRIVATE void rotate_() 247 | { 248 | THREEPARAMS("rotate"); 249 | SAVESTACK; 250 | TERNARY(SAVED1->op,SAVED1->u.num); 251 | NULLARY(SAVED2->op,SAVED2->u.num); 252 | NULLARY(SAVED3->op,SAVED3->u.num); 253 | POP(dump); 254 | } 255 | PRIVATE void dup_() 256 | { 257 | ONEPARAM("dup"); 258 | NULLARY(stk->op,stk->u.num); 259 | } 260 | 261 | /* - - - BOOLEAN - - - */ 262 | 263 | #define ANDORXOR(PROCEDURE,NAME,OPER1,OPER2) \ 264 | PRIVATE void PROCEDURE() \ 265 | { TWOPARAMS(NAME); \ 266 | SAME2TYPES(NAME); \ 267 | switch (stk->next->op) \ 268 | { case SET_: \ 269 | BINARY(SET_,stk->next->u.set OPER1 stk->u.set); \ 270 | return; \ 271 | case BOOLEAN_: case CHAR_: case INTEGER_: case LIST_: \ 272 | BINARY(BOOLEAN_,stk->next->u.num OPER2 stk->u.num); \ 273 | return; \ 274 | default: \ 275 | BADDATA(NAME); } } 276 | ANDORXOR(and_,"and",&,&&) 277 | ANDORXOR(or_,"or",|,||) 278 | ANDORXOR(xor_,"xor",^,!=) 279 | 280 | 281 | /* - - - INTEGER - - - */ 282 | 283 | PRIVATE void abs_() 284 | { 285 | ONEPARAM("abs"); 286 | INTEGER("abs"); 287 | if (stk->u.num < 0) UNARY(INTEGER_, - stk->u.num); 288 | } 289 | PRIVATE void sign_() 290 | { 291 | ONEPARAM("sign"); 292 | INTEGER("sign"); 293 | if (stk->u.num < 0) UNARY(INTEGER_,-1); 294 | else if (stk->u.num > 0) UNARY(INTEGER_,1); 295 | } 296 | #define MULDIVREM(PROCEDURE,NAME,OPER,CHECK) \ 297 | PRIVATE void PROCEDURE() \ 298 | { TWOPARAMS(NAME); \ 299 | INTEGERS2(NAME); \ 300 | CHECK; \ 301 | BINARY(INTEGER_,stk->next->u.num OPER stk->u.num); } 302 | MULDIVREM(mul_,"*",*,) 303 | MULDIVREM(rem_,"rem",%,CHECKZERO("rem")) 304 | MULDIVREM(divide_,"/",/,CHECKZERO("/")) 305 | 306 | 307 | /* - - - NUMERIC - - - */ 308 | 309 | #define PREDSUCC(PROCEDURE,NAME,OPER) \ 310 | PRIVATE void PROCEDURE() \ 311 | { ONEPARAM(NAME); \ 312 | NUMERICTYPE(NAME); \ 313 | UNARY(stk->op,stk->u.num OPER 1); } 314 | PREDSUCC(pred_,"pred",-) 315 | PREDSUCC(succ_,"succ",+) 316 | 317 | #define PLUSMINUS(PROCEDURE,NAME,OPER) \ 318 | PRIVATE void PROCEDURE() \ 319 | { TWOPARAMS(NAME); \ 320 | INTEGER(NAME); \ 321 | NUMERIC2(NAME); \ 322 | BINARY(stk->next->op,stk->next->u.num OPER stk->u.num); } 323 | PLUSMINUS(plus_,"+",+) 324 | PLUSMINUS(minus_,"-",-) 325 | 326 | #define MAXMIN(PROCEDURE,NAME,OPER) \ 327 | PRIVATE void PROCEDURE() \ 328 | { TWOPARAMS(NAME); \ 329 | SAME2TYPES(NAME); \ 330 | NUMERICTYPE(NAME); \ 331 | BINARY(stk->op, \ 332 | stk->u.num OPER stk->next->u.num ? \ 333 | stk->next->u.num : stk->u.num); } 334 | MAXMIN(max_,"max",<) 335 | MAXMIN(min_,"min",>) 336 | 337 | #define COMPREL(PROCEDURE,NAME,TYPE,OPR) \ 338 | PRIVATE void PROCEDURE() \ 339 | { int comp = 0; \ 340 | TWOPARAMS(NAME); \ 341 | switch (stk->op) \ 342 | { case BOOLEAN_: case CHAR_: case INTEGER_: \ 343 | comp = stk->next->u.num - stk->u.num OPR 0; \ 344 | break; \ 345 | case SET_: \ 346 | { int i = 0; \ 347 | while ( i < SETSIZE && \ 348 | ( (stk->next->u.set & 1 << i) == \ 349 | (stk->u.set & 1 << i) ) ) \ 350 | ++i; \ 351 | if (i == SETSIZE) i = 0; else ++i; \ 352 | if (!(stk->u.set & 1 << i)) i = -i; \ 353 | comp = i OPR 0; \ 354 | break; } \ 355 | case LIST_: \ 356 | BADDATA(NAME); \ 357 | default: \ 358 | comp = strcmp(GETSTRING(stk->next), GETSTRING(stk)) \ 359 | OPR 0; \ 360 | break; } \ 361 | BINARY(TYPE,comp); } 362 | COMPREL(eql_,"=",BOOLEAN_,==) 363 | COMPREL(neql_,"!=",BOOLEAN_,!=) 364 | COMPREL(less_,"<",BOOLEAN_,<) 365 | COMPREL(leql_,"<=",BOOLEAN_,<=) 366 | COMPREL(greater_,">",BOOLEAN_,>) 367 | COMPREL(geql_,">=",BOOLEAN_,>=) 368 | COMPREL(compare_,"compare",INTEGER_,+) 369 | 370 | /* - - - AGGREGATES - - - */ 371 | 372 | PRIVATE void first_() 373 | { 374 | ONEPARAM("first"); 375 | switch (stk->op) 376 | { case LIST_: 377 | CHECKEMPTYLIST(stk->u.lis,"first"); 378 | UNARY(stk->u.lis->op,stk->u.lis->u.num); 379 | return; 380 | case STRING_: 381 | CHECKEMPTYSTRING(stk->u.str,"first"); 382 | UNARY(CHAR_,*(stk->u.str)); 383 | return; 384 | case SET_: 385 | { int i = 0; 386 | CHECKEMPTYSET(stk->u.set,"first"); 387 | while (!(stk->u.set & (1 << i))) i++; 388 | UNARY(INTEGER_,i); 389 | return; } 390 | default: 391 | BADAGGREGATE("first"); } 392 | } 393 | PRIVATE void rest_() 394 | { 395 | ONEPARAM("rest"); 396 | switch (stk->op) 397 | { case SET_: 398 | { int i = 0; 399 | CHECKEMPTYSET(stk->u.set,"rest"); 400 | while (!(stk->u.set & (1 << i))) i++; 401 | UNARY(SET_,stk->u.set & ~(1 << i)); 402 | break; } 403 | case STRING_: 404 | { char *s = stk->u.str; 405 | CHECKEMPTYSTRING(s,"rest"); 406 | UNARY(STRING_, ++s); 407 | break; } 408 | case LIST_: 409 | CHECKEMPTYLIST(stk->u.lis,"rest"); 410 | UNARY(LIST_,stk->u.lis->next); 411 | return; 412 | default: 413 | BADAGGREGATE("rest"); } 414 | } 415 | PRIVATE void uncons_() 416 | { 417 | ONEPARAM("uncons"); 418 | switch (stk->op) 419 | { case SET_: 420 | { int i = 0; long set = stk->u.set; 421 | CHECKEMPTYSET(set,"uncons"); 422 | while (!(set & (1 << i))) i++; 423 | UNARY(INTEGER_,i); 424 | NULLARY(SET_,set & ~(1 << i)); 425 | break; } 426 | case STRING_: 427 | { char *s = stk->u.str; 428 | CHECKEMPTYSTRING(s,"uncons"); 429 | UNARY(CHAR_,*s); 430 | NULLARY(STRING_,++s); 431 | break; } 432 | case LIST_: 433 | SAVESTACK; 434 | CHECKEMPTYLIST(SAVED1->u.lis,"uncons"); 435 | UNARY(SAVED1->u.lis->op,SAVED1->u.lis->u.num); 436 | NULLARY(LIST_,SAVED1->u.lis->next); 437 | POP(dump); 438 | return; 439 | default: 440 | BADAGGREGATE("uncons"); } 441 | } 442 | PRIVATE void unswons_() 443 | { 444 | ONEPARAM("unswons"); 445 | switch (stk->op) 446 | { case SET_: 447 | { int i = 0; long set = stk->u.set; 448 | CHECKEMPTYSET(set,"unswons"); 449 | while (!(set & (1 << i))) i++; 450 | UNARY(SET_,set & ~(1 << i)); 451 | NULLARY(INTEGER_,i); 452 | break; } 453 | case STRING_: 454 | { char *s = stk->u.str; 455 | CHECKEMPTYSTRING(s,"unswons"); 456 | UNARY(STRING_,++s); 457 | NULLARY(CHAR_,*(--s)); 458 | break; } 459 | case LIST_: 460 | SAVESTACK; 461 | CHECKEMPTYLIST(SAVED1->u.lis,"unswons"); 462 | UNARY(LIST_,SAVED1->u.lis->next); 463 | NULLARY(SAVED1->u.lis->op,SAVED1->u.lis->u.num); 464 | POP(dump); 465 | return; 466 | default: 467 | BADAGGREGATE("unswons"); } 468 | } 469 | PRIVATE int equal_aux(Node *n1, Node *n2); /* forward */ 470 | 471 | PRIVATE int equal_list_aux(n1,n2) 472 | Node *n1, *n2; 473 | { 474 | if (n1 == NULL && n2 == NULL) return 1; 475 | if (n1 == NULL || n2 == NULL) return 0; 476 | if (equal_aux(n1,n2)) 477 | return equal_list_aux(n1->next,n2->next); 478 | else return 0; 479 | } 480 | PRIVATE int equal_aux(n1,n2) 481 | Node *n1, *n2; 482 | { 483 | if (n1 == NULL && n2 == NULL) return 1; 484 | if (n1 == NULL || n2 == NULL) return 0; 485 | switch (n1->op) 486 | { case BOOLEAN_: case CHAR_: case INTEGER_: 487 | if (n2->op != BOOLEAN_ && n2->op != CHAR_ && 488 | n2->op != INTEGER_) 489 | return 0; 490 | return n1->u.num == n2->u.num; 491 | case SET_ : 492 | if (n2->op != SET_) return 0; 493 | return n1->u.num == n2->u.num; 494 | case LIST_ : 495 | if (n2->op != LIST_) return 0; 496 | return equal_list_aux(n1->u.lis,n2->u.lis); 497 | default: 498 | return strcmp(GETSTRING(n1),GETSTRING(n2)) == 0; } 499 | } 500 | PRIVATE void equal_() 501 | { 502 | TWOPARAMS("equal"); 503 | BINARY(BOOLEAN_,equal_aux(stk,stk->next)); 504 | } 505 | #define INHAS(PROCEDURE,NAME,AGGR,ELEM) \ 506 | PRIVATE void PROCEDURE() \ 507 | { int found = 0; \ 508 | TWOPARAMS(NAME); \ 509 | switch (AGGR->op) \ 510 | { case SET_: \ 511 | found = ((AGGR->u.set) & (1 << ELEM->u.num)) > 0; \ 512 | break; \ 513 | case STRING_: \ 514 | { char *s; \ 515 | for (s = AGGR->u.str; \ 516 | *s != '\0' && *s != ELEM->u.num; \ 517 | s++); \ 518 | found = *s != '\0'; \ 519 | break; } \ 520 | case LIST_: \ 521 | { Node *n = AGGR->u.lis; \ 522 | while (n != NULL && n->u.num != ELEM->u.num) \ 523 | n = n->next; \ 524 | found = n != NULL; \ 525 | break; } \ 526 | default: \ 527 | BADAGGREGATE(NAME); } \ 528 | BINARY(BOOLEAN_,found); \ 529 | } 530 | INHAS(in_,"in",stk,stk->next) 531 | INHAS(has_,"has",stk->next,stk) 532 | 533 | #define OF_AT(PROCEDURE,NAME,AGGR,INDEX) \ 534 | PRIVATE void PROCEDURE() \ 535 | { TWOPARAMS(NAME); \ 536 | switch (AGGR->op) \ 537 | { case SET_: \ 538 | { int i; int indx = INDEX->u.num; \ 539 | CHECKEMPTYSET(AGGR->u.set,NAME); \ 540 | for (i = 0; i < SETSIZE; i++) \ 541 | { if (AGGR->u.set & (1 << i)) \ 542 | { if (indx == 0) \ 543 | {BINARY(INTEGER_,i); return;} \ 544 | indx--; } } \ 545 | INDEXTOOLARGE(NAME); \ 546 | return; } \ 547 | case STRING_: \ 548 | if (strlen(AGGR->u.str) < (size_t)INDEX->u.num) \ 549 | INDEXTOOLARGE(NAME); \ 550 | BINARY(CHAR_,AGGR->u.str[INDEX->u.num]); \ 551 | return; \ 552 | case LIST_: \ 553 | { Node *n = AGGR->u.lis; int i = INDEX->u.num; \ 554 | CHECKEMPTYLIST(n,NAME); \ 555 | while (i > 0) \ 556 | { if (n->next == NULL) \ 557 | INDEXTOOLARGE(NAME); \ 558 | n = n->next; i--; } \ 559 | BINARY(n->op,n->u.num); \ 560 | return; } \ 561 | default: \ 562 | BADAGGREGATE(NAME); } \ 563 | } 564 | OF_AT(of_,"of",stk,stk->next) 565 | OF_AT(at_,"at",stk->next,stk) 566 | 567 | PRIVATE void choice_() 568 | { 569 | THREEPARAMS("choice"); 570 | if (stk->next->next->u.num) 571 | stk = newnode(stk->next->op,stk->next->u.num, 572 | stk->next->next->next); 573 | else stk = newnode(stk->op,stk->u.num, 574 | stk->next->next->next); 575 | } 576 | PRIVATE void opcase_() 577 | { 578 | Node *n; 579 | ONEPARAM("opcase"); 580 | LIST("opcase"); 581 | n = stk->u.lis; 582 | CHECKEMPTYLIST(n,"opcase"); 583 | while ( n->next != NULL && 584 | n->op == LIST_ && 585 | n->u.lis->op != stk->next->op ) 586 | n = n->next; 587 | CHECKLIST(n->op,"opcase"); 588 | UNARY(LIST_, 589 | n->next != NULL ? n->u.lis->next : n->u.lis); 590 | } 591 | #define CONS_SWONS(PROCEDURE,NAME,AGGR,ELEM) \ 592 | PRIVATE void PROCEDURE() \ 593 | { TWOPARAMS(NAME); \ 594 | Node *temp; \ 595 | switch (AGGR->op) \ 596 | { case LIST_: \ 597 | temp = newnode(ELEM->op, ELEM->u.num, AGGR->u.lis); \ 598 | BINARY(LIST_,temp); \ 599 | break; \ 600 | case SET_: \ 601 | CHECKSETMEMBER(ELEM,NAME); \ 602 | BINARY(SET_,AGGR->u.set | (1 << ELEM->u.num)); \ 603 | break; \ 604 | case STRING_: \ 605 | { char *s; \ 606 | s = (char *) malloc(strlen(AGGR->u.str) + 2); \ 607 | s[0] = ELEM->u.num; \ 608 | strcpy(++s,AGGR->u.str); \ 609 | BINARY(STRING_,--s); \ 610 | break; } \ 611 | default: \ 612 | BADAGGREGATE(NAME); } \ 613 | } 614 | CONS_SWONS(cons_,"cons",stk,stk->next) 615 | CONS_SWONS(swons_,"swons",stk->next,stk) 616 | 617 | PRIVATE void drop_() 618 | { int n = stk->u.num; 619 | TWOPARAMS("drop"); 620 | switch (stk->next->op) 621 | { case SET_: 622 | { int i; int result = 0; 623 | for (i = 0; i < SETSIZE; i++) 624 | if (stk->next->u.set & (1 << i)) 625 | { if (n < 1) result = result | (1 << i); 626 | else n--; } 627 | BINARY(SET_,result); 628 | return; } 629 | case STRING_: 630 | { char *result = stk->next->u.str; 631 | while (n-- > 0 && *result != '\0') ++result; 632 | BINARY(STRING_,result); 633 | return; } 634 | case LIST_: 635 | { Node *result = stk->next->u.lis; 636 | while (n-- > 0 && result != NULL) result = result->next; 637 | BINARY(LIST_,result); 638 | return; } 639 | default: 640 | BADAGGREGATE("drop"); } 641 | } 642 | 643 | PRIVATE void take_() 644 | { int n = stk->u.num; 645 | TWOPARAMS("take"); 646 | switch (stk->next->op) 647 | { case SET_: 648 | { int i; int result = 0; 649 | for (i = 0; i < SETSIZE; i++) 650 | if (stk->next->u.set & (1 << i)) 651 | { if (n > 0) 652 | { --n; result = result | (1 << i); } 653 | else break; } 654 | BINARY(SET_,result); 655 | return; } 656 | case STRING_: 657 | { int i; char *old, *p, *result; 658 | i = stk->u.num; 659 | old = stk->next->u.str; 660 | p = result = (char *) malloc(strlen(old) - i + 1); 661 | while (i-- > 0) *p++ = *old++; 662 | BINARY(STRING_,result); 663 | return; } 664 | case LIST_: 665 | { int i = stk->u.num; 666 | if (i < 1) { BINARY(LIST_,NULL); return; } 667 | dump1 = newnode(LIST_,stk->next->u.lis,dump1);/* old */ 668 | dump2 = newnode(LIST_,NULL, dump2); /* head */ 669 | dump3 = newnode(LIST_,NULL, dump3); /* last */ 670 | while (DMP1 != NULL && i-- > 0) 671 | { if (DMP2 == NULL) /* first */ 672 | { DMP2 = newnode(DMP1->op,DMP1->u.num,NULL); 673 | DMP3 = DMP2; } 674 | else /* further */ 675 | { Node *temp = newnode(DMP1->op,DMP1->u.num,NULL); 676 | DMP3->next = temp; 677 | DMP3 = DMP3->next; } 678 | DMP1 = DMP1->next; } 679 | DMP3->next = NULL; 680 | BINARY(LIST_,DMP2); 681 | POP(dump1); POP(dump2); POP(dump3); 682 | return; } 683 | default: 684 | BADAGGREGATE("take"); } 685 | } 686 | PRIVATE void concat_() 687 | { 688 | TWOPARAMS("concat"); 689 | switch (stk->op) 690 | { case SET_: 691 | BINARY(SET_,stk->next->u.set | stk->u.set); 692 | return; 693 | case STRING_: 694 | { char *s, *p; 695 | s = p = (char *)malloc(strlen(stk->next->u.str) + 696 | strlen(stk->u.str) + 1); 697 | while ((*p++ = *(stk->next->u.str)++) != '\0'); 698 | --p; /* don't want terminating null */ 699 | while ((*p++ = *(stk->u.str)++) != '\0'); 700 | BINARY(STRING_,s); 701 | return; } 702 | case LIST_: 703 | if (stk->next->u.lis == NULL) 704 | { BINARY(LIST_,stk->u.lis); return; } 705 | dump1 = newnode(LIST_,stk->next->u.lis,dump1);/* old */ 706 | dump2 = newnode(LIST_,NULL,dump2); /* head */ 707 | dump3 = newnode(LIST_,NULL,dump3); /* last */ 708 | while (DMP1 != NULL) 709 | { if (DMP2 == NULL) /* first */ 710 | { DMP2 = 711 | newnode(DMP1->op, 712 | DMP1->u.num,NULL); 713 | DMP3 = DMP2; } 714 | else /* further */ 715 | { Node *temp = 716 | newnode(DMP1->op, 717 | DMP1->u.num,NULL); 718 | DMP3->next = temp; 719 | DMP3 = DMP3->next; }; 720 | DMP1 = DMP1->next; } 721 | DMP3->next = stk->u.lis; 722 | BINARY(LIST_,DMP2); 723 | POP(dump1); 724 | POP(dump2); 725 | POP(dump3); 726 | return; 727 | default: 728 | BADAGGREGATE("concat"); }; 729 | } 730 | PRIVATE void null_() 731 | { 732 | ONEPARAM("null"); 733 | UNARY(BOOLEAN_, 734 | stk->op == STRING_ ? *(stk->u.str) == '\0' : ! stk->u.num); 735 | /* 736 | switch (stk->op) 737 | { case STRING_: 738 | UNARY(BOOLEAN_, *(stk->u.str) == '\0'); 739 | break; 740 | default: 741 | UNARY(BOOLEAN_, ! stk->u.num); } 742 | */ 743 | } 744 | PRIVATE void nullval_() 745 | { 746 | ONEPARAM("nullval"); 747 | if (stk->op == STRING_) 748 | UNARY(STRING_,""); else 749 | UNARY(stk->op,0); 750 | } 751 | PRIVATE void not_() 752 | { 753 | ONEPARAM("not"); 754 | switch (stk->op) 755 | { case SET_: 756 | UNARY(SET_,~ stk->u.set); 757 | break; 758 | case STRING_: 759 | UNARY(BOOLEAN_, *(stk->u.str) != '\0'); 760 | break; 761 | case BOOLEAN_: case CHAR_: case INTEGER_: case LIST_: 762 | UNARY(BOOLEAN_, ! stk->u.num); 763 | break; 764 | default: 765 | BADDATA("not"); } 766 | } 767 | PRIVATE void size_() 768 | { 769 | int siz = 0; 770 | ONEPARAM("size"); 771 | switch (stk->op) 772 | { case SET_: 773 | { int i; 774 | for (i = 0; i < SETSIZE; i++) 775 | if (stk->u.set & (1 << i)) siz++; 776 | break; } 777 | case STRING_: 778 | siz = strlen(stk->u.str); 779 | break; 780 | case LIST_: 781 | { Node *e = stk->u.lis; 782 | while (e != NULL) {e = e->next; siz++;}; 783 | break; } 784 | default : 785 | BADDATA("size"); } 786 | UNARY(INTEGER_,siz); 787 | } 788 | PRIVATE void small_() 789 | { 790 | int sml = 0; 791 | ONEPARAM("small"); 792 | switch (stk->op) 793 | { case BOOLEAN_: case INTEGER_: 794 | sml = stk->u.num < 2; 795 | break; 796 | case SET_: 797 | if (stk->u.set == 0) sml = 1; else 798 | { int i = 0; 799 | while (!(stk->u.set & (1 << i))) i++; 800 | D( printf("small: first member found is %d\n",i); ) 801 | sml = (stk->u.set & ~(1 << i)) == 0; } 802 | break; 803 | case STRING_: 804 | sml = stk->u.str[0] == '\0' || stk->u.str[1] == '\0'; 805 | break; 806 | case LIST_: 807 | sml = stk->u.lis == NULL || stk->u.lis->next == NULL; 808 | break; 809 | default: 810 | BADDATA("small"); } 811 | UNARY(BOOLEAN_,sml); 812 | } 813 | #define TYPE(PROCEDURE,NAME,REL,TYP) \ 814 | PRIVATE void PROCEDURE() \ 815 | { ONEPARAM(NAME); \ 816 | UNARY(BOOLEAN_,stk->op REL TYP); } 817 | TYPE(integer_,"integer",==,INTEGER_) 818 | TYPE(char_,"char",==,CHAR_) 819 | TYPE(logical_,"logical",==,BOOLEAN_) 820 | TYPE(string_,"string",==,STRING_) 821 | TYPE(set_,"set",==,SET_) 822 | TYPE(list_,"list",==,LIST_) 823 | TYPE(leaf_,"leaf",!=,LIST_) 824 | TYPE(user_,"user",==,USR_) 825 | 826 | #define USETOP(PROCEDURE,NAME,TYPE,BODY) \ 827 | PRIVATE void PROCEDURE() \ 828 | { ONEPARAM(NAME); TYPE(NAME); BODY; POP(stk); } 829 | USETOP( put_,"put",ONEPARAM, writefactor(stk);printf(" ")) 830 | USETOP( putch_,"putch",NUMERICTYPE, printf("%c", (char) stk->u.num) ) 831 | USETOP( setecho_,"setecho",NUMERICTYPE, echoflag = stk->u.num ) 832 | USETOP( setautoput_,"setautoput",NUMERICTYPE, autoput = stk->u.num ) 833 | USETOP( settracegc_,"settracegc",NUMERICTYPE, tracegc = stk->u.num ) 834 | USETOP( include_,"include",STRING, doinclude(stk->u.str) ) 835 | USETOP( system_,"system",STRING, system(stk->u.str) ) 836 | 837 | PRIVATE void get_() 838 | { 839 | getsym(); 840 | readfactor(); 841 | } 842 | 843 | PUBLIC void dummy_() 844 | { 845 | /* never called */ 846 | } 847 | #define HELP(PROCEDURE,REL) \ 848 | PRIVATE void PROCEDURE() \ 849 | { Entry *i = symtabindex; \ 850 | while (i != symtab) \ 851 | if ((--i)->name[0] REL '_') \ 852 | printf("%s ",i->name); \ 853 | printf("\n"); } 854 | HELP(help1_,!=) 855 | HELP(h_help1_,==) 856 | 857 | /* - - - - - C O M B I N A T O R S - - - - - */ 858 | 859 | #ifdef TRACING 860 | PRIVATE void writestack(Node *n) 861 | { 862 | if (n) { 863 | writestack(n->next); 864 | if (n->next) 865 | putchar(' '); 866 | writefactor(n); 867 | } 868 | } 869 | #endif 870 | 871 | PUBLIC void exeterm(n) 872 | Node *n; 873 | { 874 | Node *stepper; 875 | start: 876 | if (n == NULL) return; 877 | conts = newnode(LIST_,n,conts); 878 | while (conts->u.lis != NULL) 879 | { 880 | if (tracegc > 5) 881 | { printf("exeterm1: %ld ",(long)conts->u.lis); 882 | printnode(conts->u.lis); } 883 | stepper = conts->u.lis; 884 | #ifdef TRACING 885 | writestack(stk); 886 | printf(" : "); 887 | writeterm(stepper); 888 | putchar('\n'); 889 | #endif 890 | conts->u.lis = conts->u.lis->next; 891 | switch (stepper->op) 892 | { case BOOLEAN_: case CHAR_: case INTEGER_: 893 | case SET_: case STRING_: case LIST_: 894 | NULLARY(stepper->op,stepper->u.num); break; 895 | case USR_: 896 | if (stepper->u.ent->u.body == NULL) 897 | execerror("definition", stepper->u.ent->name); 898 | if (stepper->next == NULL) 899 | { POP(conts); 900 | n = stepper->u.ent->u.body; 901 | goto start; } 902 | else exeterm(stepper->u.ent->u.body ); 903 | break; 904 | case COPIED_: case ILLEGAL_: 905 | printf("exeterm: attempting to execute bad node\n"); 906 | printnode(stepper); 907 | break; 908 | default: 909 | D( printf("trying to do "); ) 910 | D( writefactor(dump1); ) 911 | (*(stepper->u.proc))(); break; } 912 | if (tracegc > 5) 913 | { printf("exeterm2: %ld ",(long)stepper); 914 | printnode(stepper); } 915 | /* 916 | stepper = stepper->next; } 917 | */ 918 | } 919 | POP(conts); 920 | D( printf("after execution, stk is:\n"); ) 921 | D( writeterm(stk); ) 922 | D( printf("\n"); ) 923 | } 924 | PRIVATE void x_() 925 | { 926 | ONEPARAM("x"); 927 | ONEQUOTE("x"); 928 | exeterm(stk->u.lis); 929 | } 930 | PRIVATE void i_() 931 | { 932 | ONEPARAM("i"); 933 | ONEQUOTE("i"); 934 | SAVESTACK; 935 | POP(stk); 936 | exeterm(SAVED1->u.lis); 937 | POP(dump); 938 | } 939 | PRIVATE void dip_() 940 | { 941 | TWOPARAMS("dip"); 942 | ONEQUOTE("dip"); 943 | SAVESTACK; 944 | stk = stk->next->next; 945 | exeterm(SAVED1->u.lis); 946 | NULLARY(SAVED2->op,SAVED2->u.num); 947 | POP(dump); 948 | } 949 | #define DIPPED(PROCEDURE,NAME,PARAMCOUNT,ARGUMENT) \ 950 | PRIVATE void PROCEDURE() \ 951 | { PARAMCOUNT(NAME); \ 952 | SAVESTACK; \ 953 | POP(stk); \ 954 | ARGUMENT(); \ 955 | NULLARY(SAVED1->op,SAVED1->u.num); \ 956 | POP(dump); \ 957 | } 958 | DIPPED(popd_,"popd",TWOPARAMS,pop_) 959 | DIPPED(dupd_,"dupd",TWOPARAMS,dup_) 960 | DIPPED(swapd_,"swapd",THREEPARAMS,swap_) 961 | DIPPED(rolldownd_,"rolldownd",FOURPARAMS,rolldown_) 962 | DIPPED(rollupd_,"rollupd",FOURPARAMS,rollup_) 963 | DIPPED(rotated_,"rotated",FOURPARAMS,rotate_) 964 | 965 | #define N_ARY(PROCEDURE,NAME,PARAMCOUNT,TOP) \ 966 | PRIVATE void PROCEDURE() \ 967 | { PARAMCOUNT(NAME); \ 968 | ONEQUOTE(NAME); \ 969 | SAVESTACK; \ 970 | POP(stk); \ 971 | exeterm(SAVED1->u.lis); \ 972 | stk = newnode(stk->op,stk->u.num,TOP); \ 973 | POP(dump); \ 974 | } 975 | N_ARY(nullary_,"nullary",ONEPARAM,SAVED2) 976 | N_ARY(unary_,"unary",TWOPARAMS,SAVED3) 977 | N_ARY(binary_,"binary",THREEPARAMS,SAVED4) 978 | N_ARY(ternary_,"ternary",FOURPARAMS,SAVED5) 979 | /* 980 | PRIVATE void nullary_() 981 | { 982 | ONEPARAM("nullary"); 983 | SAVESTACK; 984 | POP(stk); 985 | exeterm(SAVED1->u.lis); 986 | stk->next = SAVED2; 987 | POP(dump); 988 | } 989 | */ 990 | PRIVATE void times_() 991 | { 992 | int i,n; 993 | TWOPARAMS("times"); 994 | ONEQUOTE("times"); 995 | SAVESTACK; 996 | stk = stk->next->next; 997 | n = SAVED2->u.num; 998 | for (i = 1; i <= n; i++) 999 | exeterm(SAVED1->u.lis); 1000 | POP(dump); 1001 | } 1002 | PRIVATE void infra_() 1003 | { 1004 | TWOPARAMS("infra"); 1005 | ONEQUOTE("infra"); 1006 | LIST2("infra"); 1007 | SAVESTACK; 1008 | stk = SAVED2->u.lis; 1009 | exeterm(SAVED1->u.lis); 1010 | stk = newnode(LIST_,stk,SAVED3); 1011 | POP(dump); 1012 | } 1013 | PRIVATE void app1_() 1014 | { 1015 | TWOPARAMS("app1"); 1016 | ONEQUOTE("app1"); 1017 | SAVESTACK; 1018 | POP(stk); 1019 | exeterm(SAVED1->u.lis); 1020 | POP(dump); 1021 | } 1022 | PRIVATE void cleave_() 1023 | { /* X [P1] [P2] cleave ==> X1 X2 */ 1024 | THREEPARAMS("cleave"); 1025 | TWOQUOTES("cleave"); 1026 | SAVESTACK; 1027 | stk = SAVED3; 1028 | exeterm(SAVED2->u.lis); /* [P1] */ 1029 | dump1 = newnode(stk->op,stk->u.num,dump1); /* X1 */ 1030 | stk = SAVED3; 1031 | exeterm(SAVED1->u.lis); /* [P2] */ 1032 | dump1 = newnode(stk->op,stk->u.num,dump1); /* X2 */ 1033 | stk = dump1; dump1 = dump1->next->next; stk->next->next = SAVED4; 1034 | POP(dump); 1035 | } 1036 | PRIVATE void app11_() 1037 | { 1038 | THREEPARAMS("app11"); 1039 | ONEQUOTE("app11"); 1040 | app1_(); 1041 | stk->next = stk->next->next; 1042 | } 1043 | PRIVATE void app2_() 1044 | { /* Y Z [P] app2 ==> Y' Z' */ 1045 | THREEPARAMS("app2"); 1046 | ONEQUOTE("app2"); 1047 | SAVESTACK; 1048 | stk = SAVED2->next; /* just Y on top */ 1049 | exeterm(SAVED1->u.lis); /* execute P */ 1050 | dump1 = newnode(stk->op,stk->u.num,dump1); /* save P(Y) */ 1051 | stk = newnode(SAVED2->op,SAVED2->u.num, 1052 | SAVED3->next); /* just Z on top */ 1053 | exeterm(SAVED1->u.lis); /* execute P */ 1054 | dump1 = newnode(stk->op,stk->u.num,dump1); /* save P(Z) */ 1055 | stk = dump1; dump1 = dump1->next->next; stk->next->next = SAVED4; 1056 | POP(dump); 1057 | } 1058 | PRIVATE void app3_() 1059 | { /* X Y Z [P] app3 ==> X' Y' Z' */ 1060 | FOURPARAMS("app3"); 1061 | ONEQUOTE("app3"); 1062 | SAVESTACK; 1063 | stk = SAVED3->next; /* just X on top */ 1064 | exeterm(SAVED1->u.lis); /* execute P */ 1065 | dump1 = newnode(stk->op,stk->u.num,dump1); /* save p(X) */ 1066 | stk = newnode(SAVED3->op,SAVED3->u.num, 1067 | SAVED4->next); /* just Y on top */ 1068 | exeterm(SAVED1->u.lis); /* execute P */ 1069 | dump1 = newnode(stk->op,stk->u.num,dump1); /* save P(Y) */ 1070 | stk = newnode(SAVED2->op,SAVED2->u.num, 1071 | SAVED4->next); /* just Z on top */ 1072 | exeterm(SAVED1->u.lis); /* execute P */ 1073 | dump1 = newnode(stk->op,stk->u.num,dump1); /* save P(Z) */ 1074 | stk = dump1; dump1 = dump1->next->next->next; 1075 | stk->next->next->next = SAVED5; 1076 | POP(dump); 1077 | } 1078 | PRIVATE void app4_() 1079 | { /* X Y Z W [P] app4 ==> X' Y' Z' W' */ 1080 | FIVEPARAMS("app4"); 1081 | ONEQUOTE("app4"); 1082 | SAVESTACK; 1083 | stk = SAVED4->next; /* just X on top */ 1084 | exeterm(SAVED1->u.lis); /* execute P */ 1085 | dump1 = newnode(stk->op,stk->u.num,dump1); /* save p(X) */ 1086 | stk = newnode(SAVED4->op,SAVED4->u.num, 1087 | SAVED5->next); /* just Y on top */ 1088 | exeterm(SAVED1->u.lis); /* execute P */ 1089 | dump1 = newnode(stk->op,stk->u.num,dump1); /* save P(Y) */ 1090 | stk = newnode(SAVED3->op,SAVED3->u.num, 1091 | SAVED5->next); /* just Z on top */ 1092 | exeterm(SAVED1->u.lis); /* execute P */ 1093 | dump1 = newnode(stk->op,stk->u.num,dump1); /* save P(Z) */ 1094 | stk = newnode(SAVED2->op,SAVED2->u.num, 1095 | SAVED4->next); /* just W on top */ 1096 | exeterm(SAVED1->u.lis); /* execute P */ 1097 | dump1 = newnode(stk->op,stk->u.num,dump1); /* save P(W) */ 1098 | stk = dump1; dump1 = dump1->next->next->next->next; 1099 | stk->next->next->next->next = SAVED6; 1100 | POP(dump); 1101 | } 1102 | PRIVATE void app12_() 1103 | { 1104 | /* X Y Z [P] app12 */ 1105 | THREEPARAMS("app12"); 1106 | app2_(); 1107 | stk->next->next = stk->next->next->next; /* delete X */ 1108 | } 1109 | PRIVATE void map_() 1110 | { 1111 | TWOPARAMS("map"); 1112 | ONEQUOTE("map"); 1113 | SAVESTACK; 1114 | switch(SAVED2->op) 1115 | { case LIST_: 1116 | { dump1 = newnode(LIST_,SAVED2->u.lis,dump1); /* step old */ 1117 | dump2 = newnode(LIST_,NULL,dump2); /* head new */ 1118 | dump3 = newnode(LIST_,NULL,dump3); /* last new */ 1119 | while (DMP1 != NULL) 1120 | { stk = newnode(DMP1->op, 1121 | DMP1->u.num,SAVED3); 1122 | exeterm(SAVED1->u.lis); 1123 | D( printf("map: "); writefactor(stk); printf("\n"); ) 1124 | if (DMP2 == NULL) /* first */ 1125 | { DMP2 = 1126 | newnode(stk->op,stk->u.num,NULL); 1127 | DMP3 = DMP2; } 1128 | else /* further */ 1129 | { Node *temp = 1130 | newnode(stk->op,stk->u.num,NULL); 1131 | DMP3->next = temp; 1132 | DMP3 = DMP3->next; } 1133 | DMP1 = DMP1->next; } 1134 | stk = newnode(LIST_,DMP2,SAVED3); 1135 | POP(dump3); 1136 | POP(dump2); 1137 | POP(dump1); 1138 | break; } 1139 | case STRING_: 1140 | { char *s, *resultstring; int j = 0; 1141 | resultstring = 1142 | (char *) malloc(strlen(SAVED2->u.str) + 1); 1143 | for (s = SAVED2->u.str; *s != '\0'; s++) 1144 | { stk = newnode(CHAR_,*s,SAVED3); 1145 | exeterm(SAVED1->u.lis); 1146 | resultstring[j++] = stk->u.num; } 1147 | stk = newnode(STRING_,resultstring,SAVED3); 1148 | break; } 1149 | case SET_: 1150 | { int i; long resultset = 0; 1151 | for (i = 0; i < SETSIZE; i++) 1152 | if (SAVED2->u.set & (1 << i)) 1153 | { stk = newnode(INTEGER_,i,SAVED3); 1154 | exeterm(SAVED1->u.lis); 1155 | resultset = resultset | (1 << stk->u.num); } 1156 | stk = newnode(SET_,resultset,SAVED3); 1157 | break; } 1158 | default: 1159 | BADAGGREGATE("map"); } 1160 | POP(dump); 1161 | } 1162 | PRIVATE void step_() 1163 | { 1164 | TWOPARAMS("step"); 1165 | ONEQUOTE("step"); 1166 | SAVESTACK; 1167 | stk = stk->next->next; 1168 | switch(SAVED2->op) 1169 | { case LIST_: 1170 | { dump1 = newnode(LIST_,SAVED2->u.lis,dump1); 1171 | while (DMP1 != NULL) 1172 | { NULLARY(DMP1->op,DMP1->u.num); 1173 | exeterm(SAVED1->u.lis); 1174 | DMP1 = DMP1->next; } 1175 | POP(dump1); 1176 | break; } 1177 | case STRING_: 1178 | { char *s; 1179 | for (s = SAVED2->u.str; *s != '\0'; s++) 1180 | { stk = newnode(CHAR_, *s,stk); 1181 | exeterm(SAVED1->u.lis); } 1182 | break; } 1183 | case SET_: 1184 | { int i; 1185 | for (i = 0; i < SETSIZE; i++) 1186 | if (SAVED2->u.set & (1 << i)) 1187 | { stk = newnode(INTEGER_,i,stk); 1188 | exeterm(SAVED1->u.lis); } 1189 | break; } 1190 | default: 1191 | BADAGGREGATE("step"); } 1192 | POP(dump); 1193 | } 1194 | PRIVATE void fold_() 1195 | { 1196 | swapd_(); step_(); 1197 | } 1198 | PRIVATE void cond_() 1199 | { 1200 | int result = 0; 1201 | ONEPARAM("cond"); 1202 | /* must check for QUOTES in list */ 1203 | LIST("cond"); 1204 | CHECKEMPTYLIST(stk->u.lis,"cond"); 1205 | SAVESTACK; 1206 | dump1 = newnode(LIST_,stk->u.lis,dump1); 1207 | while ( result == 0 && 1208 | DMP1 != NULL && 1209 | DMP1->next != NULL ) 1210 | { stk = SAVED2; 1211 | exeterm(DMP1->u.lis->u.lis); 1212 | result = stk->u.num; 1213 | if (!result) DMP1 = DMP1->next; } 1214 | stk = SAVED2; 1215 | if (result) exeterm(DMP1->u.lis->next); 1216 | else exeterm(DMP1->u.lis); /* default */ 1217 | POP(dump1); 1218 | POP(dump); 1219 | } 1220 | #define IF_TYPE(PROCEDURE,NAME,TYP) \ 1221 | PRIVATE void PROCEDURE() \ 1222 | { TWOPARAMS(NAME); \ 1223 | TWOQUOTES(NAME); \ 1224 | SAVESTACK; \ 1225 | stk = SAVED3; \ 1226 | exeterm(stk->op == TYP ? SAVED2->u.lis : SAVED1->u.lis);\ 1227 | POP(dump); } 1228 | IF_TYPE(ifinteger_,"ifinteger",INTEGER_) 1229 | IF_TYPE(ifchar_,"ifchar",CHAR_) 1230 | IF_TYPE(iflogical_,"iflogical",BOOLEAN_) 1231 | IF_TYPE(ifstring_,"ifstring",STRING_) 1232 | IF_TYPE(ifset_,"ifset",SET_) 1233 | IF_TYPE(iflist_,"iflist",LIST_) 1234 | PRIVATE void filter_() 1235 | { 1236 | TWOPARAMS("filter"); 1237 | ONEQUOTE("filter"); 1238 | SAVESTACK; 1239 | switch (SAVED2->op) 1240 | { case SET_ : 1241 | { int j; long resultset = 0; 1242 | for (j = 0; j < SETSIZE; j++) 1243 | { if (SAVED2->u.set & (1 << j)) 1244 | { stk = newnode(INTEGER_,j,SAVED3); 1245 | exeterm(SAVED1->u.lis); 1246 | if (stk->u.num) 1247 | resultset = resultset | (1 << j); } } 1248 | stk = newnode(SET_,resultset,SAVED3); 1249 | break; } 1250 | case STRING_ : 1251 | { char *s, *resultstring; int j = 0; 1252 | resultstring = 1253 | (char *) malloc(strlen(SAVED2->u.str) + 1); 1254 | for (s = SAVED2->u.str; *s != '\0'; s++) 1255 | { stk = newnode(CHAR_, *s, SAVED3); 1256 | exeterm(SAVED1->u.lis); 1257 | if (stk->u.num) resultstring[j++] = *s; } 1258 | resultstring[j] = '\0'; 1259 | stk = newnode(STRING_,resultstring,SAVED3); 1260 | break; } 1261 | case LIST_: 1262 | { dump1 = newnode(LIST_,SAVED2->u.lis,dump1); /* step old */ 1263 | dump2 = newnode(LIST_,NULL,dump2); /* head new */ 1264 | dump3 = newnode(LIST_,NULL,dump3); /* last new */ 1265 | while (DMP1 != NULL) 1266 | { stk = newnode(DMP1->op,DMP1->u.num,SAVED3); 1267 | exeterm(SAVED1->u.lis); 1268 | D( printf("filter: "); writefactor(stk); printf("\n"); ) 1269 | if (stk->u.num) { /* test */ 1270 | if (DMP2 == NULL) /* first */ 1271 | { DMP2 = 1272 | newnode(DMP1->op, 1273 | DMP1->u.num,NULL); 1274 | DMP3 = DMP2; } 1275 | else { /* further */ 1276 | { Node *temp = 1277 | newnode(DMP1->op, 1278 | DMP1->u.num,NULL); 1279 | DMP3->next = temp; 1280 | DMP3 = DMP3->next; } } } 1281 | DMP1 = DMP1->next; } 1282 | stk = newnode(LIST_,DMP2,SAVED3); 1283 | POP(dump3); 1284 | POP(dump2); 1285 | POP(dump1); 1286 | break; } 1287 | default : 1288 | BADAGGREGATE("filter"); } 1289 | POP(dump); 1290 | } 1291 | PRIVATE void split_() 1292 | { 1293 | TWOPARAMS("split"); 1294 | SAVESTACK; 1295 | switch (SAVED2->op) 1296 | { case SET_ : 1297 | { int j; long yes_set = 0, no_set = 0; 1298 | for (j = 0; j < SETSIZE; j++) 1299 | { if (SAVED2->u.set & (1 << j)) 1300 | { stk = newnode(INTEGER_,j,SAVED3); 1301 | exeterm(SAVED1->u.lis); 1302 | if (stk->u.num) 1303 | yes_set = yes_set | (1 << j); 1304 | else no_set = no_set | (1 << j); } } 1305 | stk = newnode(SET_,yes_set,SAVED3); 1306 | NULLARY(SET_,no_set); 1307 | break; } 1308 | case STRING_ : 1309 | { char *s, *yesstring, *nostring; int yesptr = 0, noptr = 0; 1310 | yesstring = 1311 | (char *) malloc(strlen(SAVED2->u.str) + 1); 1312 | nostring = 1313 | (char *) malloc(strlen(SAVED2->u.str) + 1); 1314 | for (s = SAVED2->u.str; *s != '\0'; s++) 1315 | { stk = newnode(CHAR_, *s, SAVED3); 1316 | exeterm(SAVED1->u.lis); 1317 | if (stk->u.num) yesstring[yesptr++] = *s; 1318 | else nostring[noptr++] = *s; } 1319 | yesstring[yesptr] = '\0'; nostring[noptr] = '\0'; 1320 | stk = newnode(STRING_,yesstring,SAVED3); 1321 | NULLARY(STRING_,nostring); 1322 | break; } 1323 | case LIST_: 1324 | { dump1 = newnode(LIST_,SAVED2->u.lis,dump1); /* step old */ 1325 | dump2 = newnode(LIST_,NULL,dump2); /* head true */ 1326 | dump3 = newnode(LIST_,NULL,dump3); /* last true */ 1327 | dump4 = newnode(LIST_,NULL,dump4); /* head false */ 1328 | dump5 = newnode(LIST_,NULL,dump5); /* last false */ 1329 | while (DMP1 != NULL) 1330 | { stk = newnode(DMP1->op,DMP1->u.num,SAVED3); 1331 | exeterm(SAVED1->u.lis); 1332 | D( printf("split: "); writefactor(stk); printf("\n"); ) 1333 | if (stk->u.num) /* pass */ 1334 | if (DMP2 == NULL) /* first */ 1335 | { DMP2 = 1336 | newnode(DMP1->op, 1337 | DMP1->u.num,NULL); 1338 | DMP3 = DMP2; } 1339 | else /* further */ 1340 | { Node *temp = 1341 | newnode(DMP1->op, 1342 | DMP1->u.num,NULL); 1343 | DMP3->next = temp; 1344 | DMP3 = DMP3->next; } 1345 | else /* fail */ 1346 | if (DMP4 == NULL) /* first */ 1347 | { DMP4 = 1348 | newnode(DMP1->op, 1349 | DMP1->u.num,NULL); 1350 | DMP5 = DMP4; } 1351 | else /* further */ 1352 | { Node *temp = 1353 | newnode(DMP1->op, 1354 | DMP1->u.num,NULL); 1355 | DMP5->next = temp; 1356 | DMP5 = DMP5->next; } 1357 | DMP1 = DMP1->next; } 1358 | stk = newnode(LIST_,DMP2,SAVED3); 1359 | NULLARY(LIST_,DMP4); 1360 | POP(dump5); 1361 | POP(dump4); 1362 | POP(dump3); 1363 | POP(dump2); 1364 | POP(dump1); 1365 | break; } 1366 | default : 1367 | BADAGGREGATE("split"); } 1368 | POP(dump); 1369 | } 1370 | #define SOMEALL(PROCEDURE,NAME,INITIAL) \ 1371 | PRIVATE void PROCEDURE() \ 1372 | { int result = INITIAL; \ 1373 | TWOPARAMS(NAME); \ 1374 | SAVESTACK; \ 1375 | switch (SAVED2->op) \ 1376 | { case SET_ : \ 1377 | { int j; \ 1378 | for (j = 0; j < SETSIZE && result == INITIAL; j++) \ 1379 | { if (SAVED2->u.set & (1 << j)) \ 1380 | { stk = newnode(INTEGER_,j,SAVED3); \ 1381 | exeterm(SAVED1->u.lis); \ 1382 | if (stk->u.num != INITIAL) \ 1383 | result = 1 - INITIAL; } } \ 1384 | break; } \ 1385 | case STRING_ : \ 1386 | { char *s; \ 1387 | for (s = SAVED2->u.str; \ 1388 | *s != '\0' && result == INITIAL; s++) \ 1389 | { stk = newnode(CHAR_,*s,SAVED3); \ 1390 | exeterm(SAVED1->u.lis); \ 1391 | if (stk->u.num != INITIAL) \ 1392 | result = 1 - INITIAL; } \ 1393 | break; } \ 1394 | case LIST_ : \ 1395 | { dump1 = newnode(LIST_,SAVED2->u.lis,dump1); \ 1396 | while (DMP1 != NULL && result == INITIAL) \ 1397 | { stk = newnode(DMP1->op, \ 1398 | DMP1->u.num,SAVED3); \ 1399 | exeterm(SAVED1->u.lis); \ 1400 | if (stk->u.num != INITIAL) \ 1401 | result = 1 - INITIAL; \ 1402 | DMP1 = DMP1->next; } \ 1403 | POP(dump1); \ 1404 | break; } \ 1405 | default : \ 1406 | BADAGGREGATE(NAME); } \ 1407 | stk = newnode(BOOLEAN_,result,SAVED3); \ 1408 | POP(dump); \ 1409 | } 1410 | SOMEALL(some_,"some",0) 1411 | SOMEALL(all_,"all",1) 1412 | 1413 | PRIVATE void primrec_() 1414 | { 1415 | int n = 0; int i; 1416 | THREEPARAMS("primrec"); 1417 | SAVESTACK; 1418 | stk = stk->next->next->next; 1419 | switch (SAVED3->op) 1420 | { case LIST_: 1421 | { Node *current = SAVED3->u.lis; 1422 | while (current != NULL) 1423 | { stk = newnode(current->op,current->u.num,stk); 1424 | current = current->next; 1425 | n++; } 1426 | break; } 1427 | case STRING_: 1428 | { char *s; 1429 | for (s = SAVED3->u.str; *s != '\0'; s++) 1430 | { stk = newnode(CHAR_, *s, stk); 1431 | n++; } 1432 | break; } 1433 | case SET_: 1434 | { int j; long set = SAVED3->u.set; 1435 | for (j = 0; j < SETSIZE; j++) 1436 | if (set & (1 << j)) 1437 | { stk = newnode(INTEGER_,j,stk); 1438 | n++; } 1439 | break; } 1440 | case INTEGER_: 1441 | { int j; 1442 | for (j = SAVED3->u.num; j > 0; j--) 1443 | { stk = newnode(INTEGER_,j, stk); 1444 | n++; } 1445 | break; } 1446 | default: 1447 | BADDATA("primrec"); } 1448 | exeterm(SAVED2->u.lis); 1449 | for (i = 1; i <= n; i++) 1450 | exeterm(SAVED1->u.lis); 1451 | POP(dump); 1452 | } 1453 | PRIVATE void tailrecaux() 1454 | { 1455 | int result; 1456 | tailrec: 1457 | dump1 = newnode(LIST_,stk,dump1); 1458 | exeterm(SAVED3->u.lis); 1459 | result = stk->u.num; 1460 | stk = DMP1; POP(dump1); 1461 | if (result) exeterm(SAVED2->u.lis); else 1462 | { exeterm(SAVED1->u.lis); 1463 | goto tailrec; } /* tail recursion optimisation */ 1464 | } 1465 | PRIVATE void tailrec_() 1466 | { 1467 | THREEPARAMS("tailrec"); 1468 | SAVESTACK; 1469 | stk = SAVED4; 1470 | tailrecaux(); 1471 | POP(dump); 1472 | } 1473 | PRIVATE void construct_() 1474 | { /* [P] [[P1] [P2] ..] -> X1 X2 .. */ 1475 | TWOPARAMS("construct"); 1476 | TWOQUOTES("construct"); 1477 | SAVESTACK; 1478 | stk = SAVED3; /* pop progs */ 1479 | dump1 = newnode(LIST_,dump2,dump1); /* save dump2 */ 1480 | dump2 = stk; /* save old stack */ 1481 | exeterm(SAVED2->u.lis); /* [P] */ 1482 | dump3 = newnode(LIST_,stk,dump3); /* save current stack */ 1483 | dump4 = newnode(LIST_,SAVED1->u.lis,dump4); /* step [..] */ 1484 | while (DMP4 != NULL) 1485 | { stk = DMP3; /* restore new stack */ 1486 | exeterm(DMP4->u.lis); 1487 | dump2 = newnode(stk->op,stk->u.num,dump2); /* result */ 1488 | DMP4 = DMP4->next; } 1489 | POP(dump4); 1490 | POP(dump3); 1491 | stk = dump2; dump2 = dump1->u.lis; /* restore dump2 */ 1492 | POP(dump1); 1493 | POP(dump); 1494 | } 1495 | PRIVATE void branch_() 1496 | { 1497 | THREEPARAMS("branch"); 1498 | TWOQUOTES("branch"); 1499 | SAVESTACK; 1500 | stk = SAVED4; 1501 | exeterm(SAVED3->u.num ? SAVED2->u.lis : SAVED1->u.lis); 1502 | POP(dump); 1503 | } 1504 | PRIVATE void while_() 1505 | { 1506 | TWOPARAMS("while"); 1507 | TWOQUOTES("while"); 1508 | SAVESTACK; 1509 | do 1510 | { stk = SAVED3; 1511 | exeterm(SAVED2->u.lis); /* TEST */ 1512 | if (! stk->u.num) break; 1513 | stk = SAVED3; 1514 | exeterm(SAVED1->u.lis); /* DO */ 1515 | SAVED3 = stk; } 1516 | while (1); 1517 | stk = SAVED3; 1518 | POP(dump); 1519 | } 1520 | PRIVATE void ifte_() 1521 | { 1522 | int result; 1523 | THREEPARAMS("ifte"); 1524 | THREEQUOTES("ifte"); 1525 | SAVESTACK; 1526 | stk = SAVED4; 1527 | exeterm(SAVED3->u.lis); 1528 | result = stk->u.num; 1529 | stk = SAVED4; 1530 | exeterm(result ? SAVED2->u.lis : SAVED1->u.lis); 1531 | POP(dump); 1532 | } 1533 | PRIVATE void condlinrecaux() 1534 | { 1535 | int result = 0; 1536 | dump1 = newnode(LIST_,SAVED1->u.lis,dump1); 1537 | dump2 = newnode(LIST_,stk,dump2); 1538 | while ( result == 0 && 1539 | DMP1 != NULL && DMP1->next != NULL ) 1540 | { stk = DMP2; 1541 | exeterm(DMP1->u.lis->u.lis); 1542 | result = stk->u.num; 1543 | if (!result) DMP1 = DMP1->next; } 1544 | stk = DMP2; 1545 | if (result) 1546 | { exeterm(DMP1->u.lis->next->u.lis); 1547 | if (DMP1->u.lis->next->next != NULL) 1548 | { condlinrecaux(); 1549 | exeterm(DMP1->u.lis->next->next->u.lis); } } 1550 | else 1551 | { exeterm(DMP1->u.lis->u.lis); 1552 | if (DMP1->u.lis->next != NULL) 1553 | { condlinrecaux(); 1554 | exeterm(DMP1->u.lis->next->u.lis); } } 1555 | POP(dump2); 1556 | POP(dump1); 1557 | } 1558 | PRIVATE void condlinrec_() 1559 | { 1560 | ONEPARAM("condlinrec"); 1561 | LIST("condlinrec"); 1562 | CHECKEMPTYLIST(stk->u.lis,"condlinrec"); 1563 | SAVESTACK; 1564 | stk = SAVED2; 1565 | condlinrecaux(); 1566 | POP(dump); 1567 | } 1568 | PRIVATE void linrecaux() 1569 | { 1570 | int result; 1571 | dump1 = newnode(LIST_,stk,dump1); 1572 | exeterm(SAVED4->u.lis); 1573 | result = stk->u.num; 1574 | stk = DMP1; POP(dump1); 1575 | if (result) exeterm(SAVED3->u.lis); else 1576 | { exeterm(SAVED2->u.lis); 1577 | linrecaux(); 1578 | exeterm(SAVED1->u.lis); } 1579 | } 1580 | PRIVATE void linrec_() 1581 | { 1582 | FOURPARAMS("linrec"); 1583 | FOURQUOTES("linrec"); 1584 | SAVESTACK; 1585 | stk = SAVED5; 1586 | linrecaux(); 1587 | POP(dump); 1588 | } 1589 | PRIVATE void reclinaux() 1590 | { 1591 | int result; 1592 | dump1 = newnode(LIST_,stk,dump1); 1593 | exeterm(SAVED4->u.lis); 1594 | result = stk->u.num; 1595 | stk = DMP1; POP(dump1); 1596 | if (result) exeterm(SAVED2->u.lis); else 1597 | { exeterm(SAVED3->u.lis); 1598 | reclinaux(); 1599 | exeterm(SAVED1->u.lis); } 1600 | } 1601 | PRIVATE void reclin_() 1602 | { 1603 | FOURPARAMS("reclin"); 1604 | FOURQUOTES("reclin"); 1605 | SAVESTACK; 1606 | stk = SAVED5; 1607 | reclinaux(); 1608 | POP(dump); 1609 | } 1610 | PRIVATE void binrecaux() 1611 | { 1612 | int result; 1613 | dump1 = newnode(LIST_,stk,dump1); 1614 | exeterm(SAVED4->u.lis); 1615 | result = stk->u.num; 1616 | stk = DMP1; POP(dump1); 1617 | if (result) exeterm(SAVED3->u.lis); else 1618 | { exeterm(SAVED2->u.lis); /* split */ 1619 | dump2 = newnode(stk->op,stk->u.num,dump2); 1620 | POP(stk); 1621 | binrecaux(); /* first */ 1622 | NULLARY(dump2->op,dump2->u.num); 1623 | POP(dump2); 1624 | binrecaux(); /* second */ 1625 | exeterm(SAVED1->u.lis); } /* combine */ 1626 | } 1627 | PRIVATE void binrec_() 1628 | { 1629 | FOURPARAMS("binrec"); 1630 | FOURQUOTES("binrec"); 1631 | SAVESTACK; 1632 | stk = SAVED5; 1633 | binrecaux(); 1634 | POP(dump); 1635 | } 1636 | PRIVATE void treestepaux(item) 1637 | Node *item; 1638 | { 1639 | if (item->op != LIST_) 1640 | { NULLARY(item->op,item->u.num); 1641 | exeterm(SAVED1->u.lis); } 1642 | else 1643 | { dump1 = newnode(LIST_,item->u.lis,dump1); 1644 | while (DMP1 != NULL) 1645 | { treestepaux(DMP1); 1646 | DMP1 = DMP1->next; } 1647 | POP(dump1); } 1648 | } 1649 | PRIVATE void treestep_() 1650 | { 1651 | TWOPARAMS("treestep"); 1652 | ONEQUOTE("treestep"); 1653 | SAVESTACK; 1654 | stk = SAVED3; 1655 | treestepaux(SAVED2); 1656 | POP(dump); 1657 | } 1658 | PRIVATE void treerecaux() 1659 | { 1660 | Node *temp; 1661 | if (stk->next->op == LIST_) 1662 | { temp = newnode(ANON_FUNCT_,treerecaux,NULL); 1663 | NULLARY(LIST_,temp); 1664 | cons_(); /* D [[[O] C] ANON_FUNCT_] */ 1665 | D( printf("treerecaux: stack = "); ) 1666 | D( writeterm(stk); printf("\n"); ) 1667 | exeterm(stk->u.lis->u.lis->next); } 1668 | else 1669 | { temp = stk; 1670 | POP(stk); 1671 | exeterm(temp->u.lis->u.lis); } 1672 | } 1673 | PRIVATE void treerec_() 1674 | { 1675 | THREEPARAMS("treerec"); 1676 | cons_(); 1677 | D( printf("deep: stack = "); writeterm(stk); printf("\n"); ) 1678 | treerecaux(); 1679 | } 1680 | PRIVATE void genrecaux() 1681 | { 1682 | Node *temp; 1683 | int result; 1684 | D( printf("genrecaux: stack = "); ) 1685 | D( writeterm(stk); printf("\n"); ) 1686 | SAVESTACK; 1687 | POP(stk); 1688 | exeterm(SAVED1->u.lis->u.lis); /* [I] */ 1689 | result = stk->u.num; 1690 | stk = SAVED2; 1691 | if (result) 1692 | exeterm(SAVED1->u.lis->next->u.lis); /* [T] */ 1693 | else 1694 | { exeterm(SAVED1->u.lis->next->next->u.lis); /* [R1] */ 1695 | NULLARY(SAVED1->op,SAVED1->u.lis); 1696 | temp = newnode(ANON_FUNCT_,genrecaux,NULL); 1697 | NULLARY(LIST_,temp); 1698 | cons_(); 1699 | exeterm(SAVED1->u.lis->next->next->next); } /* [R2] */ 1700 | POP(dump); 1701 | } 1702 | PRIVATE void genrec_() 1703 | { 1704 | FOURPARAMS("genrec"); 1705 | FOURQUOTES("genrec"); 1706 | cons_(); cons_(); cons_(); 1707 | genrecaux(); 1708 | } 1709 | PRIVATE void treegenrecaux() 1710 | { 1711 | Node *temp; 1712 | D( printf("treegenrecaux: stack = "); ) 1713 | D( writeterm(stk); printf("\n"); ) 1714 | if (stk->next->op == LIST_) 1715 | { SAVESTACK; /* begin DIP */ 1716 | POP(stk); 1717 | exeterm(SAVED1->u.lis->next->u.lis); /* [O2] */ 1718 | NULLARY(SAVED1->op,SAVED1->u.num); 1719 | POP(dump); /* end DIP */ 1720 | temp = newnode(ANON_FUNCT_,treegenrecaux,NULL); 1721 | NULLARY(LIST_,temp); 1722 | cons_(); 1723 | exeterm(stk->u.lis->u.lis->next->next); } /* [C] */ 1724 | else 1725 | { temp = stk; 1726 | POP(stk); 1727 | exeterm(temp->u.lis->u.lis); } /* [O1] */ 1728 | } 1729 | PRIVATE void treegenrec_() 1730 | { /* T [O1] [O2] [C] */ 1731 | FOURPARAMS("treegenrec"); 1732 | cons_(); cons_(); 1733 | D( printf("treegenrec: stack = "); writeterm(stk); printf("\n"); ) 1734 | treegenrecaux(); 1735 | } 1736 | 1737 | PRIVATE void o_online_manual_() 1738 | { 1739 | make_manual(0); 1740 | } 1741 | PRIVATE void l_latex_manual_() 1742 | { 1743 | make_manual(1); 1744 | } 1745 | /* - - - - - I N I T I A L I S A T I O N - - - - - */ 1746 | 1747 | static struct {char *name; void (*proc) (); char *messg1, *messg2;} 1748 | optable[] = 1749 | /* THESE MUST BE DEFINED IN THE ORDER OF THEIR VALUES */ 1750 | { 1751 | 1752 | {"__ILLEGAL", dummy_, "->", 1753 | "internal error, cannot happen - supposedly."}, 1754 | 1755 | {"__COPIED", dummy_, "->", 1756 | "no message ever, used for gc."}, 1757 | 1758 | {"__USR", dummy_, "usg", 1759 | "user node."}, 1760 | 1761 | {"__ANON_FUNCT", dummy_, "->", 1762 | "op for anonymous function call."}, 1763 | 1764 | /* LITERALS */ 1765 | 1766 | {" truth value type", dummy_, "-> B", 1767 | "The logical type, or the type of truth values. It has just two literals: true and false."}, 1768 | 1769 | {" character type", dummy_, "-> C", 1770 | "The type of characters. Literals are written with a single quote. Examples: 'A '7 '; and so on. Unix style escapes are allowed."}, 1771 | 1772 | {" integer type", dummy_, "-> I", 1773 | "The type of negative, zero or positive integers. Literals are written in decimal notation. Examples: -123 0 42."}, 1774 | 1775 | {" set type", dummy_, "-> {...}", 1776 | "The type of sets of small non-negative integers. The maximum is platform dependent, typically the range is 0..31. Literals are written inside curly braces. Examples: {} {0} {1 3 5} {19 18 17}."}, 1777 | 1778 | {" string type", dummy_, "-> \"...\" ", 1779 | "The type of strings of characters. Literals are written inside double quotes. Examples: \"\" \"A\" \"hello world\" \"123\". Unix style escapes are accepted."}, 1780 | 1781 | {" list type", dummy_, "-> [...]", 1782 | "The type of lists of values of any type (including lists), or the type of quoted programs which may contain operators or combinators. Literals of this type are written inside square brackets. Examples: [] [3 512 -7] [john mary] ['A 'C ['B]] [dup *]."}, 1783 | 1784 | /* OPERANDS */ 1785 | 1786 | {"false", false_, "-> false", 1787 | "Pushes the value false."}, 1788 | 1789 | {"true", true_, "-> true", 1790 | "Pushes the value true."}, 1791 | 1792 | {"maxint", maxint_, "-> maxint", 1793 | "Pushes largest integer (platform dependent). Typically it is 32 bits."}, 1794 | 1795 | {"setsize", setsize_, "-> setsize", 1796 | "Pushes the maximum number of elements in a set (platform dependent). Typically it is 32, and set members are in the range 0..31."}, 1797 | 1798 | {"stack", stack_, ".. X Y Z -> .. X Y Z [Z Y X ..]", 1799 | "Pushes the stack as a list."}, 1800 | 1801 | {"__symtabmax", symtabmax_, "->", 1802 | "Pushes value of maximum size of the symbol table."}, 1803 | 1804 | {"__symtabindex", symtabindex_, "->", 1805 | "Pushes current size of the symbol table."}, 1806 | 1807 | {"__dump", dump_, "->", 1808 | "debugging only: pushes the dump as a list."}, 1809 | 1810 | {"conts", conts_, "-> [[P] [Q] ..]", 1811 | "Pushes current continuations."}, 1812 | 1813 | {"autoput", autoput_, "-> I", 1814 | "Pushes current value of flag for automatic output, I = 0..2."}, 1815 | 1816 | {"echo", echo_, "-> I", 1817 | "Pushes value of echo flag, I = 0..3."}, 1818 | 1819 | {"clock", clock_, "-> I", 1820 | "Pushes the integer value of current CPU usage in hundreds of a second."}, 1821 | 1822 | {"__memorymax", memorymax_, "->", 1823 | "Pushes value of total size of memory."}, 1824 | 1825 | /* OPERATORS */ 1826 | 1827 | {"id", id_, "->", 1828 | "Identity function, does nothing. Any program of the form P id Q is equivalent to just P Q."}, 1829 | 1830 | {"dup", dup_, " X -> X X", 1831 | "Pushes an extra copy of X onto stack."}, 1832 | 1833 | {"swap", swap_, " X Y -> Y X", 1834 | "Interchanges X and Y on top of the stack."}, 1835 | 1836 | {"rollup", rollup_, "X Y Z -> Z X Y", 1837 | "Moves X and Y up, moves Z down"}, 1838 | 1839 | {"rolldown", rolldown_, "X Y Z -> Y Z X", 1840 | "Moves Y and Z down, moves X up"}, 1841 | 1842 | {"rotate", rotate_, "X Y Z -> Z Y X", 1843 | "Interchanges X and Z"}, 1844 | 1845 | {"pop", pop_, " X ->", 1846 | "Removes X from top of the stack."}, 1847 | 1848 | {"choice", choice_, "B T F -> X", 1849 | "If B is true, then X = T else X = F."}, 1850 | 1851 | {"or", or_, "X Y -> Z", 1852 | "Z is the union of sets X and Y, logical disjunction for truth values."}, 1853 | 1854 | {"xor", xor_, "X Y -> Z", 1855 | "Z is the symmetric difference of sets X and Y, logical exclusive disjunction for truth values."}, 1856 | 1857 | {"and", and_, "X Y -> Z", 1858 | "Z is the intersection of sets X and Y, logical conjunction for truth values."}, 1859 | 1860 | {"not", not_, "X -> Y", 1861 | "Y is the complement of set X, logical negation for truth values."}, 1862 | 1863 | {"+", plus_, "M I -> N", 1864 | "Numeric N is the result of adding integer I to numeric M."}, 1865 | 1866 | {"-", minus_, "M I -> N", 1867 | "Numeric N is the result of subtracting integer I from numeric M."}, 1868 | 1869 | {"*", mul_, "I J -> K", 1870 | "Integer K is the product of integers I and J."}, 1871 | 1872 | {"/", divide_, "I J -> K", 1873 | "Integer K is the (rounded) ratio of integers I and J."}, 1874 | 1875 | {"rem", rem_, "I J -> K", 1876 | "Integer K is the remainder of dividing I by J."}, 1877 | 1878 | {"sign", sign_, "I -> J", 1879 | "Integer J is the sign (-1 or 0 or +1) of integer I."}, 1880 | 1881 | {"abs", abs_, "I -> J", 1882 | "Integer J is the absolute value (0,1,2..) of integer I."}, 1883 | 1884 | {"pred", pred_, "M -> N", 1885 | "Numeric N is the predecessor of numeric M."}, 1886 | 1887 | {"succ", succ_, "M -> N", 1888 | "Numeric N is the successor of numeric M."}, 1889 | 1890 | {"max", max_, "N1 N2 -> N", 1891 | "N is the maximum of numeric values N1 and N2."}, 1892 | 1893 | {"min", min_, "N1 N2 -> N", 1894 | "N is the minimum of numeric values N1 and N2."}, 1895 | 1896 | {"unstack", unstack_, "[X Y ..] -> ..Y X", 1897 | "The list [X Y ..] becomes the new stack."}, 1898 | 1899 | {"cons", cons_, "X A -> B", 1900 | "Aggregate B is A with a new member X (first member for sequences)."}, 1901 | 1902 | {"swons", swons_, "A X -> B", 1903 | "Aggregate B is A with a new member X (first member for sequences)."}, 1904 | 1905 | {"first", first_, "A -> F", 1906 | "F is the first member of the non-empty aggregate A."}, 1907 | 1908 | {"rest", rest_, "A -> R", 1909 | "R is the non-empty aggregate A with its first member removed."}, 1910 | 1911 | {"compare", compare_, "A B -> I", 1912 | "I (=-1,0,+1) is the comparison of aggregates A and B. The values correspond to the predicates <=, =, >=."}, 1913 | 1914 | {"at", at_, "A I -> X", 1915 | "X (= A[I]) is the member of A at position I."}, 1916 | 1917 | {"of", of_, "I A -> X", 1918 | "X (= A[I]) is the I-th member of aggregate A."}, 1919 | 1920 | {"size", size_, "A -> I", 1921 | "Integer I is the number of elements of aggregate A."}, 1922 | 1923 | {"opcase", opcase_, "X [..[X Xs]..] -> [Xs]", 1924 | "Indexing on type of X, returns the list [Xs]."}, 1925 | 1926 | {"uncons", uncons_, "A -> F R", 1927 | "F and R are the first and the rest of non-empty aggregate A."}, 1928 | 1929 | {"unswons", unswons_, "A -> R F", 1930 | "R and F are the rest and the first of non-empty aggregate A."}, 1931 | 1932 | {"drop", drop_, "A N -> B", 1933 | "Aggregate B is the result of deleting the first N elements of A."}, 1934 | 1935 | {"take", take_, "A N -> B", 1936 | "Aggregate B is the result of retaining just the first N elements of A."}, 1937 | 1938 | {"concat", concat_, "S T -> U", 1939 | "Sequence U is the concatenation of sequences S and T."}, 1940 | 1941 | {"name", name_, "sym -> \"sym\"", 1942 | "For operators and combinators, the string \"sym\" is the name of item sym, for literals sym the result string is its type."}, 1943 | 1944 | {"body", body_, "U -> [P]", 1945 | "Quotation [P] is the body of user-defined symbol U."}, 1946 | 1947 | {"nullval", nullval_, "A -> A0", 1948 | "A0 is the empty aggregate of the type of A, or the 0-value of numerics."}, 1949 | 1950 | /* PREDICATES */ 1951 | 1952 | {"null", null_, "X -> B", 1953 | "Tests for empty aggregate X or zero numeric."}, 1954 | 1955 | {"small", small_, "X -> B", 1956 | "Tests whether aggregate X has 0 or 1 members, or numeric 0 or 1."}, 1957 | 1958 | {">=", geql_, "X Y -> B", 1959 | "Either both X and Y are numeric or both are strings or symbols. Tests whether X greater than or equal to Y."}, 1960 | 1961 | {">", greater_, "X Y -> B", 1962 | "Either both X and Y are numeric or both are strings or symbols. Tests whether X greater than Y."}, 1963 | 1964 | {"<=", leql_, "X Y -> B", 1965 | "Either both X and Y are numeric or both are strings or symbols. Tests whether X less than or equal to Y."}, 1966 | 1967 | {"<", less_, "X Y -> B", 1968 | "Either both X and Y are numeric or both are strings or symbols. Tests whether X less than Y."}, 1969 | 1970 | {"!=", neql_, "X Y -> B", 1971 | "Either both X and Y are numeric or both are strings or symbols. Tests whether X not equal to Y."}, 1972 | 1973 | {"=", eql_, "X Y -> B", 1974 | "Either both X and Y are numeric or both are strings or symbols. Tests whether X equal to Y."}, 1975 | 1976 | {"equal", equal_, "T U -> B", 1977 | "(Recursively) tests whether trees T and U are identical."}, 1978 | 1979 | {"has", has_, "A X -> B", 1980 | "Tests whether aggregate A has X as a member."}, 1981 | 1982 | {"in", in_, "X A -> B", 1983 | "Tests whether X is a member of aggregate A."}, 1984 | 1985 | {"integer", integer_, "X -> B", 1986 | "Tests whether X is an integer."}, 1987 | 1988 | {"char", char_, "X -> B", 1989 | "Tests whether X is a character."}, 1990 | 1991 | {"logical", logical_, "X -> B", 1992 | "Tests whether X is a logical."}, 1993 | 1994 | {"set", set_, "X -> B", 1995 | "Tests whether X is a set."}, 1996 | 1997 | {"string", string_, "X -> B", 1998 | "Tests whether X is a string."}, 1999 | 2000 | {"list", list_, "X -> B", 2001 | "Tests whether X is a list."}, 2002 | 2003 | {"leaf", leaf_, "X -> B", 2004 | "Tests whether X is not a list."}, 2005 | 2006 | {"user", user_, "X -> B", 2007 | "Tests whether X is a user-defined symbol."}, 2008 | 2009 | /* COMBINATORS */ 2010 | 2011 | {"i", i_, "[P] -> ...", 2012 | "Executes P. So, [P] i == P."}, 2013 | 2014 | {"x", x_, "[P]i -> ...", 2015 | "Executes P without popping [P]. So, [P] x == [P] P."}, 2016 | 2017 | {"dip", dip_, "X [P] -> ... X", 2018 | "Saves X, executes P, pushes X back."}, 2019 | 2020 | {"popd", popd_, "Y Z -> Z", 2021 | "As if defined by: popd == [pop] dip "}, 2022 | 2023 | {"dupd", dupd_, "Y Z -> Y Y Z", 2024 | "As if defined by: dupd == [dup] dip"}, 2025 | 2026 | {"swapd", swapd_, "X Y Z -> Y X Z", 2027 | "As if defined by: swapd == [swap] dip"}, 2028 | 2029 | {"rollupd", rollupd_, "X Y Z W -> Z X Y W", 2030 | "As if defined by: rollupd == [rollup] dip"}, 2031 | 2032 | {"rolldownd", rolldownd_, "X Y Z W -> Y Z X W", 2033 | "As if defined by: rolldownd == [rolldown] dip "}, 2034 | 2035 | {"rotated", rotated_, "X Y Z W -> Z Y X W", 2036 | "As if defined by: rotated == [rotate] dip"}, 2037 | 2038 | {"app1", app1_, "X [P] -> R", 2039 | "Executes P, pushes result R on stack without X."}, 2040 | 2041 | {"app2", app2_, "X1 X2 [P] -> R1 R2", 2042 | "Executes P twice, with X1 and X2 on top of the stack. Returns the two values R1 and R2."}, 2043 | 2044 | {"app3", app3_, "X1 X2 X3 [P] -> R1 R2 R3", 2045 | "Executes P three times, with Xi, returns Ri (i = 1..3)."}, 2046 | 2047 | {"app4", app4_, "X1 X2 X3 X4 [P] -> R1 R2 R3 R4", 2048 | "Executes P four times, with Xi, returns Ri (i = 1..4)."}, 2049 | 2050 | {"app11", app11_, "X Y [P] -> R", 2051 | "Executes P, pushes result R on stack."}, 2052 | 2053 | {"app12", app12_, "X Y1 Y2 [P] -> R1 R2", 2054 | "Executes P twice, with Y1 and Y2, returns R1 and R2."}, 2055 | 2056 | {"construct", construct_, "[P] [[P1] [P2] ..] -> R1 R2 ..", 2057 | "Saves state of stack and then executes [P]. Then executes each [Pi] to give Ri pushed onto saved stack."}, 2058 | 2059 | {"nullary", nullary_, "[P] -> R", 2060 | "Executes P, which leaves R on top of the stack. No matter how many parameters this consumes, none are removed from the stack."}, 2061 | 2062 | {"unary", unary_, "X [P] -> R", 2063 | "Executes P, which leaves R on top of the stack. No matter how many parameters this consumes, exactly one is removed from the stack."}, 2064 | 2065 | {"binary", binary_, "X Y [P] -> R", 2066 | "Executes P, which leaves R on top of the stack. No matter how many parameters this consumes, exactly two removed from the stack."}, 2067 | 2068 | {"ternary", ternary_, "X Y Z [P] -> R", 2069 | "Executes P, which leaves R on top of the stack. No matter how many parameters this consumes, exactly three are removed from the stack."}, 2070 | 2071 | {"cleave", cleave_, "X [P1] [P2] -> R1 R2", 2072 | "Executes P1 and P2, each with X on top, producing two results."}, 2073 | 2074 | {"branch", branch_, "B [T] [F] -> ...", 2075 | "If B is true, then executes T else executes F."}, 2076 | 2077 | {"ifte", ifte_, "[B] [T] [F] -> ...", 2078 | "Executes B. If that yields true, then executes T else executes F."}, 2079 | 2080 | {"ifinteger", ifinteger_, "X [T] [E] -> ...", 2081 | "If X is an integer, executes T else executes E."}, 2082 | 2083 | {"ifchar", ifchar_, "X [T] [E] -> ...", 2084 | "If X is a character, executes T else executes E."}, 2085 | 2086 | {"iflogical", iflogical_, "X [T] [E] -> ...", 2087 | "If X is a logical or truth value, executes T else executes E."}, 2088 | 2089 | {"ifset", ifset_, "X [T] [E] -> ...", 2090 | "If X is a set, executes T else executes E."}, 2091 | 2092 | {"ifstring", ifstring_, "X [T] [E] -> ...", 2093 | "If X is a string, executes T else executes E."}, 2094 | 2095 | {"iflist", iflist_, "X [T] [E] -> ...", 2096 | "If X is a list, executes T else executes E."}, 2097 | 2098 | {"cond", cond_, "[..[[Bi] Ti]..[D]] -> ...", 2099 | "Tries each Bi. If that yields true, then executes Ti and exits. If no Bi yields true, executes default D."}, 2100 | 2101 | {"while", while_, "[B] [D] -> ...", 2102 | "While executing B yields true executes D."}, 2103 | 2104 | {"linrec", linrec_, "[I] [T] [R1] [R2] -> ...", 2105 | "Executes I. If that yields true, executes T. Else executes R1, recurses, executes R2."}, 2106 | 2107 | {"reclin", reclin_, "[I] [R1] [T] [R2] -> ...", 2108 | "Executes I. If that yields true, executes T. Else executes R1, recurses, executes R2. (= linrec with 2nd and 3rd parameter interchanged.)"}, 2109 | 2110 | {"tailrec", tailrec_, "[P] [T] [R1] -> ...", 2111 | "Executes P. If that yields true, executes T. Else executes R1, recurses."}, 2112 | 2113 | {"binrec", binrec_, "[B] [T] [R1] [R2] -> ...", 2114 | "Executes P. If that yields true, executes T. Else uses R1 to produce two intermediates, recurses on both, then executes R2 to combines their results."}, 2115 | 2116 | {"genrec", genrec_, "[B] [T] [R1] [R2] -> ...", 2117 | "Executes B, if that yields true executes T. Else executes R1 and then [[B] [T] [R1] [R2] genrec] R2."}, 2118 | 2119 | {"condlinrec", condlinrec_, "[ [C1] [C2] .. [D] ] -> ...", 2120 | "Each [Ci] is of the forms [[B] [T]] or [[B] [R1] [R2]]. Tries each B. If that yields true and there is just a [T], executes T and exit. If there are [R1] and [R2], executes R1, recurses, executes R2. Subsequent case are ignored. If no B yields true, then [D] is used. It is of the forms [[T]] or [[R1] [R2]]. For the former, executes T. For the latter executes R1, recurses, executes R2."}, 2121 | 2122 | {"step", step_, "A [P] -> ...", 2123 | "Sequentially putting members of aggregate A onto stack, executes P for each member of A."}, 2124 | 2125 | {"fold", fold_, "A V0 BIN -> V1", 2126 | "Starting with value V0, sequentially puts members of aggregate A onto stack andcombines with binary operator BIN to finally prodice value V1"}, 2127 | 2128 | {"map", map_, "A [P] -> B", 2129 | "Executes P on each member of aggregate A, collects results in sametype aggregate B."}, 2130 | 2131 | {"times", times_, "[P] N -> ...", 2132 | "Executes P N times."}, 2133 | 2134 | {"infra", infra_, "L1 [P] -> L2", 2135 | "Using list L1 as stack, executes P and returns a new list L2."}, 2136 | 2137 | {"primrec", primrec_, "X [I] [C] -> R", 2138 | "Executes I to obtain an initial value R0. For integer X uses increasing positive integers up to X and combines by C for new R. For aggregate X uses successive members and combines by C for new R."}, 2139 | 2140 | {"filter", filter_, "A [B] -> A1", 2141 | "Uses test B to filter aggregate A producing sametype aggregate A1."}, 2142 | 2143 | {"split", split_, "A [B] -> A1 A2", 2144 | "Uses test B to split aggregate A into sametype aggregates A1 and A2 ."}, 2145 | 2146 | {"some", some_, "A [B] -> X", 2147 | "Applies test B to members of aggregate A, X = true if some pass."}, 2148 | 2149 | {"all", all_, "A [B] -> X", 2150 | "Applies test B to members of aggregate A, X = true if all pass."}, 2151 | 2152 | {"treestep", treestep_, "T [P] -> ...", 2153 | "Recursivly traverses leaves of tree T, executes P for each leaf."}, 2154 | 2155 | {"treerec", treerec_, "T [O] [C] -> ...", 2156 | "T is a tree. If T is a leaf, executes O. Else executes [[O] [C] treerec] C."}, 2157 | 2158 | {"treegenrec", treegenrec_, "T [O1] [O2] [C] -> ...", 2159 | "T is a tree. If T is a leaf, executes O1. Else executes O2 and then [[O1] [O2] [C] treegenrec] C."}, 2160 | 2161 | /* MISCELLANEOUS */ 2162 | 2163 | {"help", help1_, "->", 2164 | "Lists all defined symmbols, including those from library files. Then lists all primitives of raw Joy."}, 2165 | 2166 | {"_help", h_help1_, "->", 2167 | "Lists all hidden symbols in library and then all hidden inbuilt symbols."}, 2168 | 2169 | {"helpdetail", helpdetail_, "[ S1 S2 .. ]", 2170 | "Gives brief help on each symbol S in the list."}, 2171 | 2172 | {"manual", o_online_manual_, "->", 2173 | "Writes this manual of all Joy primitives to output file."}, 2174 | 2175 | {"__latex_manual", l_latex_manual_, "->", 2176 | "Writes this manual of all Joy primitives in Latex to output file."}, 2177 | 2178 | {"__settracegc", settracegc_, "I ->", 2179 | "Sets value of flag for tracing garbage collection to I (= 0..5)."}, 2180 | 2181 | {"setautoput", setautoput_, "I ->", 2182 | "Sets value of flag for automatic put to I (= 0 or 1)."}, 2183 | 2184 | {"setecho", setecho_, "I ->", 2185 | "Sets value of echo flag for listing. I = 0: no echo, 1: echo, 2: with tab, 3: and linenumber."}, 2186 | 2187 | {"gc", gc_, "->", 2188 | "Initiates garbage collection."}, 2189 | 2190 | {"system", system_, "\"command\" ->", 2191 | "Escapes to shell, executes string \"command\". The string may cause execution of another program. When that has finished, the process returns to Joy."}, 2192 | 2193 | {"__memoryindex", memoryindex_, "->", 2194 | "Pushes current value of memory."}, 2195 | 2196 | {"get", get_, "-> F", 2197 | "Reads a factor from input and pushes it onto stack."}, 2198 | 2199 | {"put", put_, "X ->", 2200 | "Writes X to output, pops X off stack."}, 2201 | 2202 | {"putch", putch_, "N ->", 2203 | "N : numeric, writes character whose ASCII is N."}, 2204 | 2205 | {"include", include_, "\"filnam.ext\" ->", 2206 | "Transfers input to file whose name is \"filnam.ext\". On end-of-file returns to previous input file."}, 2207 | 2208 | {"abort", abortexecution_,"->", 2209 | "Aborts execution of current Joy program, returnsto Joy main cycle."}, 2210 | 2211 | {"quit", quit_, "->", 2212 | "Exit from Joy."}, 2213 | {0, dummy_, "->","->"} 2214 | }; 2215 | 2216 | PUBLIC void inisymboltable() /* initialise */ 2217 | { 2218 | int i; char *s; 2219 | symtabindex = symtab; 2220 | for (i = 0; i < HASHSIZE; hashentry[i++] = symtab) ; 2221 | localentry = symtab; 2222 | for (i = 0; optable[i].name; i++) 2223 | { s = optable[i].name; 2224 | /* ensure same algorithm in getsym */ 2225 | for (hashvalue = 0; *s != '\0';) hashvalue += *s++; 2226 | hashvalue %= HASHSIZE; 2227 | symtabindex->name = optable[i].name; 2228 | symtabindex->u.proc = optable[i].proc; 2229 | symtabindex->next = hashentry[hashvalue]; 2230 | hashentry[hashvalue] = symtabindex; 2231 | D( printf("entered %s in symbol table at %ld = %ld\n", \ 2232 | symtabindex->name, (long)symtabindex, \ 2233 | LOC2INT(symtabindex)); ) 2234 | symtabindex++; } 2235 | firstlibra = symtabindex; 2236 | } 2237 | PRIVATE void helpdetail_() 2238 | { 2239 | Node *n; 2240 | ONEPARAM("HELP"); 2241 | LIST("HELP"); 2242 | printf("\n"); 2243 | n = stk->u.lis; 2244 | while (n != NULL) 2245 | { if (n->op == USR_) 2246 | { printf("%s ==\n ",n->u.ent->name); 2247 | writeterm(n->u.ent->u.body); 2248 | printf("\n"); break; } 2249 | else 2250 | printf("%s : %s.\n%s\n", 2251 | optable[ (int) n->op].name, 2252 | optable[ (int) n->op].messg1, 2253 | optable[ (int) n->op].messg2); 2254 | printf("\n"); 2255 | n = n->next; } 2256 | POP(stk); 2257 | } 2258 | #define HEADER(N,NAME,HEAD) \ 2259 | if (strcmp(N,NAME) == 0) \ 2260 | { printf("\n\n"); \ 2261 | if (latex) printf("\\item[--- \\BX{"); \ 2262 | printf("%s",HEAD); \ 2263 | if (latex) printf("} ---] \\verb# #"); \ 2264 | printf("\n\n"); } 2265 | PRIVATE void make_manual(int latex) 2266 | { 2267 | int i; char * n; 2268 | for (i = BOOLEAN_; optable[i].name != 0; i++) 2269 | { n = optable[i].name; 2270 | HEADER(n," truth value type","literal") else 2271 | HEADER(n,"false","operand") else 2272 | HEADER(n,"id","operator") else 2273 | HEADER(n,"null","predicate") else 2274 | HEADER(n,"i","combinator") else 2275 | HEADER(n,"help","miscellaneous commands") 2276 | if (n[0] != '_') 2277 | { if (latex) 2278 | { if (n[0] == ' ') 2279 | { n++; printf("\\item[\\BX{"); } 2280 | else printf("\\item[\\JX{"); } 2281 | printf("%s",n); 2282 | if (latex) printf("}] \\verb#"); 2283 | printf(" : %s", optable[i].messg1); 2284 | if (latex) printf("# \\\\ \n {\\small\\verb#"); 2285 | else printf("\n"); 2286 | printf("%s", optable[i].messg2); 2287 | if (latex) printf("#}"); 2288 | printf("\n\n"); } } 2289 | } 2290 | PUBLIC char *opername(o) 2291 | int o; 2292 | { 2293 | return optable[(short)o].name; 2294 | } 2295 | /* END of INTERP.C */ 2296 | -------------------------------------------------------------------------------- /joy.vim: -------------------------------------------------------------------------------- 1 | " Vim syntax file 2 | " Language: Joy 3 | " Maintainer: Ivan Tomac 4 | " Last Change: January, 32, 2005 5 | 6 | if version < 600 7 | syntax clear 8 | elseif exists("b:current_syntax") 9 | finish 10 | endif 11 | 12 | syntax case match 13 | 14 | syntax match joyError oneline "]" 15 | 16 | syntax match joySpecial /[()\.\;]/ 17 | syntax region joyString start=/"/ end=/"/ 18 | syntax region joyList matchgroup=joyBracket start=/\[/ end=/\]/ contains=ALL 19 | syntax region joyComment start=/(\*/ end=/\*)/ 20 | syntax match joySymbol /[^\[\]"\.\; ]+/ 21 | 22 | syntax match joySpecial /==/ 23 | syntax match joyComment /[#].*/ 24 | syntax match joySpecial /LIBRA/ 25 | syntax match joySpecial /DEFINE/ 26 | syntax match joySpecial /HIDE/ 27 | syntax match joySpecial /IN/ 28 | syntax match joySpecial /END/ 29 | syntax match joySpecial /MODULE/ 30 | syntax match joySpecial /PRIVATE/ 31 | syntax match joySpecial /PUBLIC/ 32 | syntax match joySpecial /CONST/ 33 | syntax match joySpecial /INLINE/ 34 | syntax match joySpecial /%IF/ 35 | syntax match joySpecial /%SET/ 36 | syntax match joySpecial /%INCLUDE/ 37 | syntax match joySpecial /%PUT/ 38 | syntax match joySpecial /%LISTING/ 39 | syntax match joySpecial /%TRACE/ 40 | 41 | if version >= 508 || !exists("did_joy_syntax_inits") 42 | if version < 508 43 | let did_joy_syntax_inits = 1 44 | command -nargs=+ HiLink hi link 45 | else 46 | command -nargs=+ HiLink hi def link 47 | endif 48 | 49 | HiLink joyString String 50 | HiLink joySymbol Identifier 51 | HiLink joyList Identifier 52 | HiLink joySpecial Keyword 53 | HiLink joyBracket Function 54 | HiLink joyComment Comment 55 | HiLink joyError Error 56 | 57 | delcommand HiLink 58 | endif 59 | 60 | let b:current_syntax = "joy" 61 | -------------------------------------------------------------------------------- /main.c: -------------------------------------------------------------------------------- 1 | /* 2 | module : main.c 3 | version : 1.1.1.3 4 | date : 12/16/24 5 | */ 6 | /* file: main.c */ 7 | 8 | #include 9 | #include 10 | #include 11 | #include 12 | #include 13 | #define ALLOC 14 | #include "globals.h" 15 | 16 | PUBLIC void inilinebuffer(); /* file scan.c */ 17 | PUBLIC int endofbuffer(); 18 | PUBLIC void doinclude(char *filnam); 19 | PUBLIC void getsym(); 20 | PUBLIC void inimem1(); /* file utils.c */ 21 | PUBLIC void inimem2(); 22 | PUBLIC void inisymboltable(); 23 | PUBLIC void readterm(); 24 | PUBLIC void writeterm(Node *n); 25 | PUBLIC void writefactor(Node *n); 26 | PUBLIC void error(char *message); 27 | PUBLIC void exeterm(Node *n); /* file interp.c */ 28 | PUBLIC void abortexecution_(); /* forward */ 29 | 30 | PUBLIC void enterglobal() 31 | { 32 | location = symtabindex++; 33 | D( printf("getsym, new: '%s'\n",id); ) 34 | location->name = (char *) malloc(strlen(id) + 1); 35 | strcpy(location->name,id); 36 | location->u.body = NULL; /* may be assigned in definition */ 37 | location->next = hashentry[hashvalue]; 38 | D( printf("entered %s at %ld\n",id,LOC2INT(location)); ) 39 | hashentry[hashvalue] = location; 40 | } 41 | PUBLIC void lookup() 42 | { 43 | D( printf("%s hashes to %d\n",id,hashvalue); ) 44 | location = localentry; 45 | while (location != symtab && 46 | strcmp(id,location->name) != 0) 47 | location = location->next; 48 | if (location != symtab) /* found in local table */ 49 | { 50 | D( printf("found %s in local table\n",id); ) 51 | return; } 52 | location = hashentry[hashvalue]; 53 | while (location != symtab && 54 | strcmp(id,location->name) != 0) 55 | location = location->next; 56 | if (location == symtab) /* not found, enter in global */ 57 | enterglobal(); 58 | } 59 | PRIVATE void defsequence(int hidden); /* forward */ 60 | 61 | PRIVATE void definition(hidden) 62 | int hidden; 63 | { 64 | Entry *here = NULL; 65 | Entry *savelocalentry; 66 | if (sym == HIDE) 67 | { getsym(); 68 | savelocalentry = localentry; 69 | defsequence(1); 70 | if (sym == IN) getsym(); 71 | else error(" IN expected in HIDE-declaration"); 72 | defsequence(hidden); 73 | localentry = savelocalentry; 74 | if (sym == END) getsym(); 75 | else error(" END expected in HIDE-declaration"); 76 | return; } 77 | if (sym != ATOM) 78 | { error("atom expected at start of definition"); 79 | abortexecution_(); } 80 | else if (hidden) 81 | { location = symtabindex++; 82 | D( printf("hidden definition '%s' at %ld \n",id,LOC2INT(location)); ) 83 | location->name = (char *) malloc(strlen(id) + 1); 84 | strcpy(location->name, id); 85 | location->u.body = NULL; /* may be assigned later */ 86 | location->next = localentry; 87 | localentry = location; } 88 | else lookup(); 89 | if (location < firstlibra) 90 | { printf("warning: overwriting inbuilt '%s'\n",location->name); 91 | enterglobal(); } 92 | here = location; getsym(); 93 | if (sym == EQDEF) getsym(); 94 | else error(" == expected in definition"); 95 | readterm(); 96 | D( printf("assigned this body: "); ) 97 | D( writeterm(stk->u.lis); ) 98 | D( printf("\n"); ) 99 | if (here != NULL) here->u.body = stk->u.lis; 100 | stk = stk->next; 101 | } 102 | 103 | PRIVATE void defsequence(hidden) 104 | int hidden; 105 | { 106 | definition(hidden); 107 | while (sym == SEMICOL) 108 | { getsym(); definition(hidden); } 109 | } 110 | 111 | jmp_buf begin; 112 | 113 | PUBLIC void abortexecution_() 114 | { 115 | conts = dump = dump1 = dump2 = dump3 = dump4 = dump5 = NULL; 116 | longjmp(begin,0); 117 | } 118 | PUBLIC void execerror(message,op) 119 | char *message, *op; 120 | { 121 | printf("run time error: %s needed for %s\n",message,op); 122 | abortexecution_(); 123 | } 124 | PUBLIC void quit_() 125 | { 126 | long totaltime; 127 | totaltime = clock() - startclock; 128 | printf("time: %ld CPU, %d gc (= %ld%%)\n", 129 | totaltime, gc_clock, 130 | totaltime ? (1004*gc_clock)/(10*totaltime) : 0); 131 | exit(EXIT_SUCCESS); 132 | } 133 | static int mustinclude = 1; 134 | 135 | #define CHECK(D,NAME) \ 136 | if (D) \ 137 | { printf("-> %s is not empty:\n",NAME); \ 138 | writeterm(D); printf("\n"); } 139 | 140 | int main(int argc, char *argv[]) 141 | { 142 | if (argc == 2 && !freopen(argv[1], "r", stdin)) { 143 | fprintf(stderr, "failed to open the file '%s'.\n", argv[1]); 144 | exit(EXIT_FAILURE); 145 | } 146 | printf("JOY - compiled at %s on %s \n",__TIME__,__DATE__); 147 | startclock = clock(); 148 | gc_clock = 0; 149 | echoflag = INIECHOFLAG; 150 | tracegc = INITRACEGC; 151 | autoput = INIAUTOPUT; 152 | ch = ' '; 153 | inilinebuffer(); 154 | inisymboltable(); 155 | inimem1(); inimem2(); 156 | setjmp(begin); 157 | D( printf("starting main loop\n"); ) 158 | while (1) 159 | { if (mustinclude) 160 | { mustinclude = 0; 161 | if (fopen("usrlib.joy","r")) 162 | doinclude("usrlib.joy"); } 163 | getsym(); 164 | if (sym == LIBRA) 165 | { inimem1(); 166 | getsym(); defsequence(0); 167 | inimem2(); } 168 | else 169 | { readterm(); 170 | D( printf("program is: "); writeterm(stk->u.lis); printf("\n"); ) 171 | prog = stk->u.lis; 172 | stk = stk->next; 173 | conts = NULL; 174 | exeterm(prog); 175 | if (conts || dump || dump1 || dump2 || dump3 || dump4 || dump5) 176 | { printf("the dumps are not empty\n"); 177 | CHECK(conts,"conts"); 178 | CHECK(dump,"dump"); CHECK(dump1,"dump1"); 179 | CHECK(dump2,"dump2"); CHECK(dump3,"dump3"); 180 | CHECK(dump4,"dump4"); CHECK(dump5,"dump5"); } 181 | if (autoput && stk != NULL) 182 | { writefactor(stk); printf("\n"); stk = stk->next; } } } 183 | } 184 | -------------------------------------------------------------------------------- /makefile: -------------------------------------------------------------------------------- 1 | # makefile for Joy 2 | 3 | HDRS = globals.h 4 | SRCS = interp.c scan.c utils.c main.c 5 | OBJS = interp.o scan.o utils.o main.o 6 | # Use CC environment variable 7 | CFLAGS = -O3 -Wall -Wextra -Wpedantic -Werror -Wno-char-subscripts -Wno-int-conversion -Wno-old-style-definition 8 | 9 | joy: $(OBJS) 10 | $(CC) $(OBJS) -o $@ 11 | 12 | $(OBJS):$(HDRS) 13 | 14 | clean: 15 | rm -f $(OBJS) 16 | -------------------------------------------------------------------------------- /scan.c: -------------------------------------------------------------------------------- 1 | /* 2 | module : scan.c 3 | version : 1.1.1.2 4 | date : 12/16/24 5 | */ 6 | /* FILE : scan.c */ 7 | #include 8 | #include 9 | #include 10 | #include 11 | #include "globals.h" 12 | 13 | #define EOLN '\n' 14 | 15 | PUBLIC void quit_(); /* file main.c */ 16 | PUBLIC void execerror(char *message, char *op); 17 | 18 | static FILE *infile[INPSTACKMAX]; 19 | static int ilevel; 20 | static int linenumber = 0; 21 | static char linbuf[INPLINEMAX]; 22 | static int linelength, currentcolumn = 0; 23 | static int errorcount = 0; 24 | 25 | PUBLIC void inilinebuffer() 26 | { 27 | ilevel = 0; infile[ilevel] = stdin; 28 | } 29 | 30 | PUBLIC void putline() 31 | { 32 | if (echoflag > 2) printf("%4d",linenumber); 33 | if (echoflag > 1) printf("\t"); 34 | printf("%s\n",linbuf); 35 | } 36 | PRIVATE void getch() 37 | { 38 | char c; 39 | if (currentcolumn == linelength) 40 | { Again: 41 | currentcolumn = 0; linelength = 0; 42 | linenumber++; 43 | while ((c = getc(infile[ilevel])) != EOLN) 44 | { linbuf[linelength++] = c; 45 | if (feof(infile[ilevel])) 46 | { ilevel--; 47 | D( printf("reset to level %d\n",ilevel); ) 48 | if (ilevel < 0) quit_(); } } 49 | linbuf[linelength++] = '\0'; 50 | if (echoflag) putline(); 51 | if (linbuf[0] == SHELLESCAPE) 52 | { system(&linbuf[1 ]); goto Again; } } 53 | ch = linbuf[currentcolumn++]; 54 | } 55 | PUBLIC int endofbuffer() 56 | { 57 | return (currentcolumn == linelength); 58 | } 59 | PUBLIC void error(message) 60 | char *message; 61 | { 62 | int i; 63 | putline(); 64 | if (echoflag > 1) putchar('\t'); 65 | for (i = 0; i < currentcolumn-2; i++) 66 | if (linbuf[i] <= ' ') putchar(linbuf[i]); else putchar(' '); 67 | printf("^\n\t%s\n",message); 68 | errorcount++; 69 | } 70 | PUBLIC void doinclude(filnam) 71 | char *filnam; 72 | { 73 | if (ilevel+1 == INPSTACKMAX) 74 | execerror("fewer include files","include"); 75 | if ((infile[ilevel+1] = fopen(filnam,"r")) != NULL) 76 | { ilevel++; return; } 77 | execerror("valid file name","include"); 78 | } 79 | PRIVATE char specialchar() 80 | { 81 | getch(); 82 | switch (ch) 83 | { case 'n' : return '\n'; 84 | case 't' : return '\t'; 85 | case 'b' : return '\b'; 86 | case 'r' : return '\r'; 87 | case 'f' : return '\f'; 88 | case '\'': return '\''; 89 | case '\"': return '\"'; 90 | default : 91 | if (ch >= '0' && ch <= '9') 92 | { int i; 93 | num = ch - '0'; 94 | for (i = 0; i < 2; i++) 95 | { getch(); 96 | if (ch < '0' || ch > '9') 97 | { currentcolumn++; /* to get pointer OK */ 98 | error("digit expected"); 99 | currentcolumn--; } 100 | num = 10 * num + ch - '0'; } 101 | return num; } 102 | else return ch; } 103 | } 104 | PUBLIC void getsym() 105 | { 106 | Start: 107 | while (ch <= ' ') getch(); 108 | switch (ch) 109 | { case '(': 110 | getch(); 111 | if (ch == '*') 112 | { getch(); 113 | do {while (ch != '*') getch(); getch();} 114 | while (ch != ')'); 115 | getch(); goto Start; } 116 | else {sym = LPAREN; return;} 117 | case ')': 118 | sym = RPAREN; getch(); return; 119 | case '[': 120 | sym = LBRACK; getch(); return; 121 | case ']': 122 | sym = RBRACK; getch(); return; 123 | case '{': 124 | sym = LBRACE; getch(); return; 125 | case '}': 126 | sym = RBRACE; getch(); return; 127 | case '.': 128 | sym = PERIOD; getch(); return; 129 | case ';': 130 | sym = SEMICOL; getch(); return; 131 | case '\'': 132 | getch(); 133 | if (ch == '\\') ch = specialchar(); 134 | num = ch; 135 | sym = CHAR_; getch(); return; 136 | case '"': 137 | { char string[INPLINEMAX]; 138 | register int i = 0; 139 | getch(); 140 | while (ch != '"' && !endofbuffer()) 141 | { if (ch == '\\') ch = specialchar(); 142 | string[i++] = ch; getch();} 143 | string[i] = '\0'; getch(); 144 | D( printf("getsym: string = %s\n",string); ) 145 | num = (long) malloc(strlen(string) + 1); 146 | strcpy((char *) num, string); 147 | sym = STRING_; return; } 148 | case '-': /* PERHAPS unary minus */ 149 | case '0': case '1': case '2': case '3': case '4': 150 | case '5': case '6': case '7': case '8': case '9': 151 | { int sign = 1; 152 | if ( isdigit(ch) || 153 | ( currentcolumn < linelength && 154 | isdigit((int)linbuf[currentcolumn]) ) ) 155 | { if (! isdigit(ch)) {sign = -1; getch();} 156 | num = 0; 157 | do {num = 10 * num + ch - '0'; getch();} 158 | while (isdigit(ch)); 159 | num *= sign; sym = INTEGER_; return; } } 160 | /* ELSE '-' is not unary minus, fall through */ 161 | goto Next; 162 | Next: 163 | default: 164 | { int i = 0; 165 | hashvalue = 0; /* ensure same algorithm in inisymtab */ 166 | do { if (i < ALEN-1) {id[i++] = ch; hashvalue += ch;} 167 | getch(); } 168 | while (isalpha(ch) || isdigit(ch) || 169 | ch == '=' || ch == '_' || ch == '-'); 170 | id[i] = '\0'; hashvalue %= HASHSIZE; 171 | if (isupper((int)id[1])) 172 | { if (strcmp(id,"LIBRA") == 0 || strcmp(id,"DEFINE") == 0) 173 | { sym = LIBRA; return; } 174 | if (strcmp(id,"HIDE") == 0) 175 | { sym = HIDE; return; } 176 | if (strcmp(id,"IN") == 0) 177 | { sym = IN; return; } 178 | if (strcmp(id,"END") == 0) 179 | { sym = END; return; } 180 | /* possibly other uppers here */ 181 | } 182 | if (strcmp(id,"==") == 0) 183 | {sym = EQDEF; return;} 184 | sym = ATOM; return; } } 185 | } 186 | -------------------------------------------------------------------------------- /test2/__dump.joy: -------------------------------------------------------------------------------- 1 | (* 2 | module : __dump.joy 3 | version : 1.2 4 | date : 08/20/22 5 | *) 6 | __dump [] equal. 7 | -------------------------------------------------------------------------------- /test2/__latex_manual.joy: -------------------------------------------------------------------------------- 1 | (* 2 | module : __latex_manual.joy 3 | version : 1.3 4 | date : 08/20/22 5 | *) 6 | __latex_manual. 7 | -------------------------------------------------------------------------------- /test2/__memoryindex.joy: -------------------------------------------------------------------------------- 1 | (* 2 | module : __memoryindex.joy 3 | version : 1.3 4 | date : 08/20/22 5 | *) 6 | 0 1 2 3 4 5 6 7 8 9 10 7 | __memoryindex dup 29 =. 8 | -------------------------------------------------------------------------------- /test2/__memorymax.joy: -------------------------------------------------------------------------------- 1 | (* 2 | module : __memorymax.joy 3 | version : 1.2 4 | date : 08/20/22 5 | *) 6 | 0 1 2 3 4 5 6 7 8 9 10 7 | __memorymax 100000 =. 8 | -------------------------------------------------------------------------------- /test2/__settracegc.joy: -------------------------------------------------------------------------------- 1 | (* 2 | module : __settracegc.joy 3 | version : 1.3 4 | date : 08/20/22 5 | *) 6 | 1 __settracegc. 7 | -------------------------------------------------------------------------------- /test2/__symtabindex.joy: -------------------------------------------------------------------------------- 1 | (* 2 | module : __symtabindex.joy 3 | version : 1.3 4 | date : 08/20/22 5 | *) 6 | __symtabindex 150 =. 7 | -------------------------------------------------------------------------------- /test2/__symtabmax.joy: -------------------------------------------------------------------------------- 1 | (* 2 | module : __symtabmax.joy 3 | version : 1.2 4 | date : 08/20/22 5 | *) 6 | __symtabmax 2000 =. 7 | -------------------------------------------------------------------------------- /test2/_help.joy: -------------------------------------------------------------------------------- 1 | (* 2 | module : _help.joy 3 | version : 1.2 4 | date : 08/20/22 5 | *) 6 | _help. 7 | -------------------------------------------------------------------------------- /test2/abort.joy: -------------------------------------------------------------------------------- 1 | (* 2 | module : abort.joy 3 | version : 1.2 4 | date : 08/20/22 5 | *) 6 | abort. 7 | -------------------------------------------------------------------------------- /test2/abs.joy: -------------------------------------------------------------------------------- 1 | (* 2 | module : abs.joy 3 | version : 1.2 4 | date : 08/20/22 5 | *) 6 | -1 abs 1 =. 7 | -1.1 abs 1.1 =. 8 | -------------------------------------------------------------------------------- /test2/add.joy: -------------------------------------------------------------------------------- 1 | (* 2 | module : add.joy 3 | version : 1.3 4 | date : 05/23/23 5 | *) 6 | 2 3 + 5 =. 7 | 'A 2 + 'C =. 8 | -------------------------------------------------------------------------------- /test2/all.joy: -------------------------------------------------------------------------------- 1 | (* 2 | module : all.joy 3 | version : 1.3 4 | date : 05/23/23 5 | *) 6 | [1 2 3] [2 <] all false =. 7 | [1 2 3] [4 <] all. 8 | "test" ['t <] all false =. 9 | "test" ['u <] all. 10 | {1 2 3} [2 <] all false =. 11 | {1 2 3} [4 <] all. 12 | 13 | [] [2 <] all. 14 | "" ['t <] all. 15 | {} [2 <] all. 16 | 17 | [1 2 3] [] all false =. 18 | "test" [] all false =. 19 | {1 2 3} [] all false =. 20 | -------------------------------------------------------------------------------- /test2/and.joy: -------------------------------------------------------------------------------- 1 | (* 2 | module : and.joy 3 | version : 1.2 4 | date : 08/20/22 5 | *) 6 | false false and false =. 7 | false true and false =. 8 | true false and false =. 9 | true true and. 10 | {1 2 3} {4 5 6} and {} =. 11 | {1 2 3} {2 3 4} and {2 3} =. 12 | -------------------------------------------------------------------------------- /test2/app1.joy: -------------------------------------------------------------------------------- 1 | (* 2 | module : app1.joy 3 | version : 1.2 4 | date : 08/20/22 5 | *) 6 | 1 2 3 [+] app1 stack [5 1] equal. 7 | -------------------------------------------------------------------------------- /test2/app11.joy: -------------------------------------------------------------------------------- 1 | (* 2 | module : app11.joy 3 | version : 1.3 4 | date : 08/20/22 5 | *) 6 | 1 2 3 [+] app11 stack [5] equal. 7 | -------------------------------------------------------------------------------- /test2/app12.joy: -------------------------------------------------------------------------------- 1 | (* 2 | module : app12.joy 3 | version : 1.3 4 | date : 08/20/22 5 | *) 6 | 1 2 3 4 [+] app12 stack [6 5 1] equal. 7 | -------------------------------------------------------------------------------- /test2/app2.joy: -------------------------------------------------------------------------------- 1 | (* 2 | module : app2.joy 3 | version : 1.2 4 | date : 08/20/22 5 | *) 6 | 2 3 [succ] app2 stack [4 3] equal. 7 | -------------------------------------------------------------------------------- /test2/app3.joy: -------------------------------------------------------------------------------- 1 | (* 2 | module : app3.joy 3 | version : 1.2 4 | date : 08/20/22 5 | *) 6 | 2 3 4 [succ] app3 stack [5 4 3] equal. 7 | -------------------------------------------------------------------------------- /test2/app4.joy: -------------------------------------------------------------------------------- 1 | (* 2 | module : app4.joy 3 | version : 1.2 4 | date : 08/20/22 5 | *) 6 | 2 3 4 5 [succ] app4 stack [6 5 4 3] equal. 7 | -------------------------------------------------------------------------------- /test2/at.joy: -------------------------------------------------------------------------------- 1 | (* 2 | module : at.joy 3 | version : 1.2 4 | date : 08/20/22 5 | *) 6 | [4 5 6] 2 at 6 =. 7 | "test" 2 at 's =. 8 | {4 5 6} 2 at 6 =. 9 | -------------------------------------------------------------------------------- /test2/autoput.joy: -------------------------------------------------------------------------------- 1 | (* 2 | module : autoput.joy 3 | version : 1.2 4 | date : 08/20/22 5 | *) 6 | autoput 1 =. 7 | -------------------------------------------------------------------------------- /test2/binary.joy: -------------------------------------------------------------------------------- 1 | (* 2 | module : binary.joy 3 | version : 1.3 4 | date : 05/23/23 5 | *) 6 | 3 4 5 [+] binary stack [9 3] equal. 7 | 8 | [] unstack. 9 | 3 4 5 [] binary stack [5 3] equal. 10 | -------------------------------------------------------------------------------- /test2/binrec.joy: -------------------------------------------------------------------------------- 1 | (* 2 | module : binrec.joy 3 | version : 1.2 4 | date : 08/20/22 5 | *) 6 | 10 [small] [] [pred dup pred] [+] binrec 55 =. 7 | -------------------------------------------------------------------------------- /test2/body.joy: -------------------------------------------------------------------------------- 1 | (* 2 | module : body.joy 3 | version : 1.2 4 | date : 08/20/22 5 | *) 6 | DEFINE last == dup rest null [first] [rest last] branch. 7 | 8 | [last] first body [dup rest null [first] [rest last] branch] equal. 9 | -------------------------------------------------------------------------------- /test2/branch.joy: -------------------------------------------------------------------------------- 1 | (* 2 | module : branch.joy 3 | version : 1.3 4 | date : 08/20/22 5 | *) 6 | 0 not [true] [false] branch. 7 | 1 not [true] [false] branch false =. 8 | -------------------------------------------------------------------------------- /test2/char.joy: -------------------------------------------------------------------------------- 1 | (* 2 | module : char.joy 3 | version : 1.2 4 | date : 08/20/22 5 | *) 6 | 10 char false =. 7 | '\n char. 8 | '\010 char. 9 | -------------------------------------------------------------------------------- /test2/choice.joy: -------------------------------------------------------------------------------- 1 | (* 2 | module : choice.joy 3 | version : 1.2 4 | date : 08/20/22 5 | *) 6 | true 1.5 2.5 choice 1.5 =. 7 | false 1.5 2.5 choice 2.5 =. 8 | -------------------------------------------------------------------------------- /test2/cleave.joy: -------------------------------------------------------------------------------- 1 | (* 2 | module : cleave.joy 3 | version : 1.3 4 | date : 08/20/22 5 | *) 6 | DEFINE sum == 0.0 [+] fold; 7 | average == [sum] [size] cleave /. 8 | 9 | [1.0 2.0 3.0] average 2 =. 10 | [4.0 5.0 6.0] average 5 =. 11 | [7.0 8.0 9.0] average 8 =. 12 | -------------------------------------------------------------------------------- /test2/clock.joy: -------------------------------------------------------------------------------- 1 | (* 2 | module : clock.joy 3 | version : 1.2 4 | date : 08/20/22 5 | *) 6 | clock. 7 | -------------------------------------------------------------------------------- /test2/compare.joy: -------------------------------------------------------------------------------- 1 | (* 2 | module : compare.joy 3 | version : 1.4 4 | date : 05/23/23 5 | *) 6 | DEFINE sum == 0 [+] fold; 7 | average == [sum] [size] cleave /. 8 | 9 | "test" "test" compare 0 =. 10 | {1 2 3} {1 2 3} compare 0 =. 11 | [pop] first [pop] first compare 0 =. 12 | [sum] first [sum] first compare 0 =. 13 | true true compare 0 =. 14 | 'A 'A compare 0 =. 15 | 10 10 compare 0 =. 16 | -------------------------------------------------------------------------------- /test2/concat.joy: -------------------------------------------------------------------------------- 1 | (* 2 | module : concat.joy 3 | version : 1.4 4 | date : 05/23/23 5 | *) 6 | [1 2 3] [4 5 6] concat [1 2 3 4 5 6] equal. 7 | "test" "uftu" concat "testuftu" =. 8 | {1 2 3} {4 5 6} concat {1 2 3 4 5 6} =. 9 | [] [1 2 3] concat [1 2 3] equal. 10 | [1 2 3] [] concat [1 2 3] equal. 11 | 12 | [1 2 3] dup [4 5 6] concat swap [7 8 9] concat stack 13 | [[1 2 3 7 8 9] [1 2 3 4 5 6]] equal. 14 | -------------------------------------------------------------------------------- /test2/cond.joy: -------------------------------------------------------------------------------- 1 | (* 2 | module : cond.joy 3 | version : 1.3 4 | date : 05/23/23 5 | *) 6 | DEFINE test == [[[1 =] "one"] 7 | [[2 =] "two"] 8 | ["other"]] cond. 9 | 10 | 1 test stack ["one" 1] equal. 11 | 12 | [] unstack. 13 | 2 test stack ["two" 2] equal. 14 | [] unstack. 15 | 3 test stack ["other" 3] equal. 16 | 17 | DEFINE test == [["other"]] cond. 18 | 19 | 1 test "other" =. 20 | 21 | DEFINE test == [[]] cond. 22 | 23 | 1 test 1 =. 24 | -------------------------------------------------------------------------------- /test2/condlinrec.joy: -------------------------------------------------------------------------------- 1 | (* 2 | module : condlinrec.joy 3 | version : 1.2 4 | date : 08/20/22 5 | *) 6 | DEFINE ack == [[[null] [pop succ]] 7 | [[pop null] [popd pred 1 swap] []] 8 | [[dup rollup [pred] dip] [swap pred ack]]] condlinrec. 9 | 10 | [[4 0]] [i swap ack] map [13] equal. 11 | -------------------------------------------------------------------------------- /test2/cons.joy: -------------------------------------------------------------------------------- 1 | (* 2 | module : cons.joy 3 | version : 1.2 4 | date : 08/20/22 5 | *) 6 | 1 [2 3] cons [1 2 3] equal. 7 | 't "est" cons "test" =. 8 | 1 {2 3} cons {1 2 3} =. 9 | -------------------------------------------------------------------------------- /test2/construct.joy: -------------------------------------------------------------------------------- 1 | (* 2 | module : construct.joy 3 | version : 1.2 4 | date : 08/20/22 5 | *) 6 | DEFINE test == [2 3] [[+] [*] [-] [/]] construct. 7 | 8 | test stack [0 -1 6 5] equal. 9 | -------------------------------------------------------------------------------- /test2/conts.joy: -------------------------------------------------------------------------------- 1 | (* 2 | module : conts.joy 3 | version : 1.2 4 | date : 08/20/22 5 | *) 6 | DEFINE cmp == stack [[[]]] equal. 7 | 8 | conts cmp. 9 | -------------------------------------------------------------------------------- /test2/dip.joy: -------------------------------------------------------------------------------- 1 | (* 2 | module : dip.joy 3 | version : 1.3 4 | date : 05/23/23 5 | *) 6 | 2 3 4 [+] dip stack [4 5] equal. 7 | 8 | [] unstack. 9 | 2 3 4 [] dip stack [4 3 2] equal. 10 | -------------------------------------------------------------------------------- /test2/divide.joy: -------------------------------------------------------------------------------- 1 | (* 2 | module : divide.joy 3 | version : 1.3 4 | date : 05/23/23 5 | *) 6 | 54 24 / 2 =. 7 | -------------------------------------------------------------------------------- /test2/drop.joy: -------------------------------------------------------------------------------- 1 | (* 2 | module : drop.joy 3 | version : 1.2 4 | date : 08/20/22 5 | *) 6 | [1 2 3] 1 drop [2 3] equal. 7 | "test" 1 drop "est" =. 8 | {1 2 3} 1 drop {2 3} =. 9 | -------------------------------------------------------------------------------- /test2/dup.joy: -------------------------------------------------------------------------------- 1 | (* 2 | module : dup.joy 3 | version : 1.2 4 | date : 08/20/22 5 | *) 6 | 2 dup stack [2 2] equal. 7 | -------------------------------------------------------------------------------- /test2/dupd.joy: -------------------------------------------------------------------------------- 1 | (* 2 | module : dupd.joy 3 | version : 1.2 4 | date : 08/20/22 5 | *) 6 | 2 3 dupd stack [3 2 2] equal. 7 | -------------------------------------------------------------------------------- /test2/echo.joy: -------------------------------------------------------------------------------- 1 | (* 2 | module : echo.joy 3 | version : 1.2 4 | date : 08/20/22 5 | *) 6 | echo 0 =. 7 | -------------------------------------------------------------------------------- /test2/eql.joy: -------------------------------------------------------------------------------- 1 | (* 2 | module : eql.joy 3 | version : 1.3 4 | date : 05/23/23 5 | *) 6 | DEFINE last == dup rest null [first] [rest last] branch; 7 | sum == 0 [+] fold; 8 | average == [sum] [size] cleave /. 9 | 10 | [sum] first [sum] first =. 11 | [sum] first [average] first = false =. 12 | [pop] first [pop] first =. 13 | [pop] first [dup] first = false =. 14 | 1 true =. 15 | false 0 =. 16 | 65 'A =. 17 | '@ 64 =. 18 | '\n 10 =. 19 | 9 '\t =. 20 | 123456789 {0 2 4 8 10 11 14 15 16 17 19 20 22 24 25 26} =. 21 | {0 2 4 8 10 11 14 15 16 17 19 20 22 24 25 26} 123456789 =. 22 | [last] first "last" =. 23 | "last" [last] first =. 24 | 0 [] equal false =. 25 | [] 0 equal false =. 26 | -------------------------------------------------------------------------------- /test2/equal.joy: -------------------------------------------------------------------------------- 1 | (* 2 | module : equal.joy 3 | version : 1.4 4 | date : 08/20/22 5 | *) 6 | DEFINE last == dup rest null [first] [rest last] branch. 7 | 8 | [last] first [last] first equal. 9 | [last] first [pop] first equal false =. 10 | [last] first "last" equal. 11 | [pop] first [last] first equal false =. 12 | [pop] first [pop] first equal. 13 | [pop] first "pop" equal. 14 | 1 true equal. 15 | 65 'A equal. 16 | '\n 10 equal. 17 | [last] first "last" equal. 18 | 0 [] equal false =. 19 | [1 2 3] [4 5 6] equal false =. 20 | [1 2 3] [1 2 3 4] equal false =. 21 | [1 2 3 4] [1 2 3] equal false =. 22 | [1 2 [3 4] 5 6] [1 2 [3 4] 5 6] equal. 23 | [1 2 [3 4] 5] [1 2 [3 4] 5 6] equal false =. 24 | [1 2 [3 4] 5 6] [1 2 [3 4] 5] equal false =. 25 | [1 2 [] 5 6] [1 2 [] 5] equal false =. 26 | [1 2 [] 5 6] [1 2 3 [] 5] equal false =. 27 | [] [] equal. 28 | [] [1 2 3] equal false =. 29 | [1 2 3] [] equal false =. 30 | [] 0 equal false =. 31 | 0 0 equal. 32 | 0 1 equal false =. 33 | 1 0 equal false =. 34 | -------------------------------------------------------------------------------- /test2/false.joy: -------------------------------------------------------------------------------- 1 | (* 2 | module : false.joy 3 | version : 1.2 4 | date : 08/20/22 5 | *) 6 | "false" intern [] cons i not. 7 | -------------------------------------------------------------------------------- /test2/filter.joy: -------------------------------------------------------------------------------- 1 | (* 2 | module : filter.joy 3 | version : 1.4 4 | date : 05/23/23 5 | *) 6 | [1 2 3 4 5 6 7 8 9 10] [5 <] filter [1 2 3 4] equal. 7 | "test" ['t <] filter "es" =. 8 | {1 2 3} [2 <] filter {1} =. 9 | 10 | [] [2 <] filter [] equal. 11 | "" ['t <] filter "" =. 12 | {} [2 <] filter {} =. 13 | 14 | [1 2 3] [] filter [1 2 3] equal. 15 | "test" [] filter "test" equal. 16 | {1 2 3} [] filter {1 2 3} equal. 17 | -------------------------------------------------------------------------------- /test2/first.joy: -------------------------------------------------------------------------------- 1 | (* 2 | module : first.joy 3 | version : 1.2 4 | date : 08/20/22 5 | *) 6 | [1 2 3] first 1 =. 7 | "test" first 't =. 8 | {1 2 3} first 1 =. 9 | -------------------------------------------------------------------------------- /test2/fold.joy: -------------------------------------------------------------------------------- 1 | (* 2 | module : fold.joy 3 | version : 1.2 4 | date : 08/20/22 5 | *) 6 | DEFINE sum == 0 [+] fold. 7 | 8 | [1 2 3] sum 6 =. 9 | -------------------------------------------------------------------------------- /test2/gc.joy: -------------------------------------------------------------------------------- 1 | (* 2 | module : gc.joy 3 | version : 1.3 4 | date : 08/20/22 5 | *) 6 | 7 | DEFINE 8 | swoncat == swap concat; 9 | from-to == (* lo hi agg *) 10 | [] cons [pop pop] swoncat 11 | [>] swap 12 | [ [dup succ] dip ] 13 | [cons] 14 | linrec; 15 | from-to-list == [] from-to. 16 | 17 | 1 9000 from-to-list pop. 18 | 19 | gc. 20 | -------------------------------------------------------------------------------- /test2/genrec.joy: -------------------------------------------------------------------------------- 1 | (* 2 | module : genrec.joy 3 | version : 1.2 4 | date : 08/20/22 5 | *) 6 | DEFINE g-fib == [small] [] [pred dup pred] [app2 +] genrec. 7 | 8 | 10 g-fib 55 =. 9 | -------------------------------------------------------------------------------- /test2/geql.joy: -------------------------------------------------------------------------------- 1 | (* 2 | module : geql.joy 3 | version : 1.3 4 | date : 05/23/23 5 | *) 6 | 10 11 >= false =. 7 | 10 10 >=. 8 | 10 9 >=. 9 | "ustu" "test" >=. 10 | [ustu] first "test" >=. 11 | [ustu] first [test] first >=. 12 | "ustu" [test] first >=. 13 | [ustu] first "test" >=. 14 | -------------------------------------------------------------------------------- /test2/get.joy: -------------------------------------------------------------------------------- 1 | (* 2 | module : get.joy 3 | version : 1.2 4 | date : 08/20/22 5 | *) 6 | get [1 2 3] equal. 7 | [1 2 3] 8 | -------------------------------------------------------------------------------- /test2/greater.joy: -------------------------------------------------------------------------------- 1 | (* 2 | module : greater.joy 3 | version : 1.3 4 | date : 05/23/23 5 | *) 6 | 10 11 > false =. 7 | 10 10 > false =. 8 | 10 9 >. 9 | "ustu" "test" >. 10 | [ustu] first "test" >. 11 | [ustu] first [test] first >. 12 | "ustu" [test] first >. 13 | [ustu] first "test" >. 14 | -------------------------------------------------------------------------------- /test2/has.joy: -------------------------------------------------------------------------------- 1 | (* 2 | module : has.joy 3 | version : 1.2 4 | date : 08/20/22 5 | *) 6 | [1 2 3] 2 has. 7 | [1 2 3] 4 has false =. 8 | "test" 'e has. 9 | "test" 'a has false =. 10 | {1 2 3} 2 has. 11 | {1 2 3} 4 has false =. 12 | -------------------------------------------------------------------------------- /test2/help.joy: -------------------------------------------------------------------------------- 1 | (* 2 | module : help.joy 3 | version : 1.2 4 | date : 08/20/22 5 | *) 6 | help. 7 | -------------------------------------------------------------------------------- /test2/helpdetail.joy: -------------------------------------------------------------------------------- 1 | (* 2 | module : helpdetail.joy 3 | version : 1.2 4 | date : 08/20/22 5 | *) 6 | DEFINE last == dup rest null [first] [rest last] branch. 7 | 8 | "test" "w" fopen 9 | [3.14 [] "" {} 10 'A true maxint helpdetail last dummy] cons helpdetail. 10 | -------------------------------------------------------------------------------- /test2/i.joy: -------------------------------------------------------------------------------- 1 | (* 2 | module : i.joy 3 | version : 1.3 4 | date : 05/23/23 5 | *) 6 | 2 3 [+] i 5 =. 7 | 8 | 2 3 [] i stack [3 2] equal. 9 | -------------------------------------------------------------------------------- /test2/id.joy: -------------------------------------------------------------------------------- 1 | (* 2 | module : id.joy 3 | version : 1.2 4 | date : 08/20/22 5 | *) 6 | id. 7 | -------------------------------------------------------------------------------- /test2/ifchar.joy: -------------------------------------------------------------------------------- 1 | (* 2 | module : ifchar.joy 3 | version : 1.2 4 | date : 08/20/22 5 | *) 6 | 'A ["ischar"] ["nochar"] ifchar "ischar" =. 7 | 10 ["ischar"] ["nochar"] ifchar "nochar" =. 8 | -------------------------------------------------------------------------------- /test2/ifinteger.joy: -------------------------------------------------------------------------------- 1 | (* 2 | module : ifinteger.joy 3 | version : 1.2 4 | date : 08/20/22 5 | *) 6 | 10 ["isinteger"] ["nointeger"] ifinteger "isinteger" =. 7 | -------------------------------------------------------------------------------- /test2/iflist.joy: -------------------------------------------------------------------------------- 1 | (* 2 | module : iflist.joy 3 | version : 1.2 4 | date : 08/20/22 5 | *) 6 | [1 2 3] ["islist"] ["nolist"] iflist "islist" =. 7 | 10 ["islist"] ["nolist"] iflist "nolist" =. 8 | -------------------------------------------------------------------------------- /test2/iflogical.joy: -------------------------------------------------------------------------------- 1 | (* 2 | module : iflogical.joy 3 | version : 1.2 4 | date : 08/20/22 5 | *) 6 | true ["islogical"] ["nological"] iflogical "islogical" =. 7 | 1 ["islogical"] ["nological"] iflogical "nological" =. 8 | -------------------------------------------------------------------------------- /test2/ifset.joy: -------------------------------------------------------------------------------- 1 | (* 2 | module : ifset.joy 3 | version : 1.2 4 | date : 08/20/22 5 | *) 6 | {1 2 3} ["ifset"] ["noset"] ifset "ifset" =. 7 | [] ["ifset"] ["noset"] ifset "noset" =. 8 | -------------------------------------------------------------------------------- /test2/ifstring.joy: -------------------------------------------------------------------------------- 1 | (* 2 | module : ifstring.joy 3 | version : 1.2 4 | date : 08/20/22 5 | *) 6 | "test" ["isstring"] ["nostring"] ifstring "isstring" =. 7 | [test] first ["isstring"] ["nostring"] ifstring "nostring" =. 8 | 10 ["isstring"] ["nostring"] ifstring "nostring" =. 9 | -------------------------------------------------------------------------------- /test2/ifte.joy: -------------------------------------------------------------------------------- 1 | (* 2 | module : ifte.joy 3 | version : 1.3 4 | date : 08/20/22 5 | *) 6 | [0 not] [true] [false] ifte. 7 | [1 not] [true] [false] ifte false =. 8 | -------------------------------------------------------------------------------- /test2/in.joy: -------------------------------------------------------------------------------- 1 | (* 2 | module : in.joy 3 | version : 1.2 4 | date : 08/20/22 5 | *) 6 | 2 [1 2 3] in. 7 | 4 [1 2 3] in false =. 8 | 'e "test" in. 9 | 'a "test" in false =. 10 | 2 {1 2 3} in. 11 | 4 {1 2 3} in false =. 12 | -------------------------------------------------------------------------------- /test2/include.joy: -------------------------------------------------------------------------------- 1 | (* 2 | module : include.joy 3 | version : 1.2 4 | date : 08/20/22 5 | *) 6 | DEFINE _include == true. 7 | 8 | ["_include" intern body null] 9 | ["include.joy" include] [] ifte. 10 | _include. 11 | -------------------------------------------------------------------------------- /test2/infra.joy: -------------------------------------------------------------------------------- 1 | (* 2 | module : infra.joy 3 | version : 1.3 4 | date : 05/23/23 5 | *) 6 | DEFINE test == [] [2 3 + 4 5 *] infra. 7 | 8 | 1 2 3 4 5 test stack [[20 5] 5 4 3 2 1] equal. 9 | 10 | DEFINE test1 == [6 7 8 9 10] [] infra. 11 | 12 | test1 stack [[6 7 8 9 10]] equal. 13 | -------------------------------------------------------------------------------- /test2/integer.joy: -------------------------------------------------------------------------------- 1 | (* 2 | module : integer.joy 3 | version : 1.2 4 | date : 08/20/22 5 | *) 6 | 10 integer. 7 | -------------------------------------------------------------------------------- /test2/leaf.joy: -------------------------------------------------------------------------------- 1 | (* 2 | module : leaf.joy 3 | version : 1.2 4 | date : 08/20/22 5 | *) 6 | [] leaf false =. 7 | 'A leaf. 8 | -------------------------------------------------------------------------------- /test2/leql.joy: -------------------------------------------------------------------------------- 1 | (* 2 | module : leql.joy 3 | version : 1.3 4 | date : 05/23/23 5 | *) 6 | 10 11 <=. 7 | 10 10 <=. 8 | 10 9 <= false =. 9 | "test" "ustu" <=. 10 | "test" [ustu] first <=. 11 | [test] first [ustu] first <=. 12 | [test] first "ustu" <=. 13 | "test" [ustu] first <=. 14 | -------------------------------------------------------------------------------- /test2/less.joy: -------------------------------------------------------------------------------- 1 | (* 2 | module : less.joy 3 | version : 1.3 4 | date : 05/23/23 5 | *) 6 | 10 11 <. 7 | 10 10 < false =. 8 | 10 9 < false =. 9 | "test" "ustu" <. 10 | "test" [ustu] first <. 11 | [test] first [ustu] first <. 12 | [test] first "ustu" <. 13 | "test" [ustu] first <. 14 | -------------------------------------------------------------------------------- /test2/linrec.joy: -------------------------------------------------------------------------------- 1 | (* 2 | module : linrec.joy 3 | version : 1.6 4 | date : 08/20/22 5 | *) 6 | DEFINE from-to == [] cons [pop pop] swoncat [>] swap 7 | [[dup succ] dip] [cons] linrec; 8 | swoncat == swap concat; 9 | from-to-list == [] from-to. 10 | 1 10 from-to-list [1 2 3 4 5 6 7 8 9 10] equal. 11 | 12 | (* 13 | 1 1000 [>] [pop pop []] [[dup succ] dip] [cons] linrec. 14 | *) 15 | -------------------------------------------------------------------------------- /test2/list.joy: -------------------------------------------------------------------------------- 1 | (* 2 | module : list.joy 3 | version : 1.2 4 | date : 08/20/22 5 | *) 6 | [1 2 3] list. 7 | 10 list false =. 8 | -------------------------------------------------------------------------------- /test2/logical.joy: -------------------------------------------------------------------------------- 1 | (* 2 | module : logical.joy 3 | version : 1.2 4 | date : 08/20/22 5 | *) 6 | false logical. 7 | true logical. 8 | {} logical false =. 9 | -------------------------------------------------------------------------------- /test2/manual.joy: -------------------------------------------------------------------------------- 1 | (* 2 | module : manual.joy 3 | version : 1.2 4 | date : 08/20/22 5 | *) 6 | manual. 7 | -------------------------------------------------------------------------------- /test2/map.joy: -------------------------------------------------------------------------------- 1 | (* 2 | module : map.joy 3 | version : 1.3 4 | date : 05/23/23 5 | *) 6 | [1 2 3] [succ] map [2 3 4] equal. 7 | "test" [succ] map "uftu" =. 8 | {1 2 3} [succ] map {2 3 4} =. 9 | 10 | [1 2 3] [] map [1 2 3] equal. 11 | "test" [] map "test" =. 12 | {1 2 3} [] map {1 2 3} =. 13 | 14 | [] [succ] map [] equal. 15 | "" [succ] map "" =. 16 | {} [succ] map {} =. 17 | -------------------------------------------------------------------------------- /test2/max.joy: -------------------------------------------------------------------------------- 1 | (* 2 | module : max.joy 3 | version : 1.4 4 | date : 05/23/23 5 | *) 6 | 'A 'B max 'B =. 7 | 'B 'A max 'B =. 8 | 1 2 max 2 =. 9 | 2 1 max 2 =. 10 | -------------------------------------------------------------------------------- /test2/maxint.joy: -------------------------------------------------------------------------------- 1 | (* 2 | module : maxint.joy 3 | version : 1.2 4 | date : 08/20/22 5 | *) 6 | "maxint" intern [] cons i 9223372036854775807 =. 7 | -------------------------------------------------------------------------------- /test2/min.joy: -------------------------------------------------------------------------------- 1 | (* 2 | module : min.joy 3 | version : 1.4 4 | date : 05/23/23 5 | *) 6 | 'A 'B min 'A =. 7 | 'B 'A min 'A =. 8 | 1 2 min 1 =. 9 | 2 1 min 1 =. 10 | -------------------------------------------------------------------------------- /test2/mul.joy: -------------------------------------------------------------------------------- 1 | (* 2 | module : mul.joy 3 | version : 1.3 4 | date : 05/23/23 5 | *) 6 | 3 100 * 300 =. 7 | -------------------------------------------------------------------------------- /test2/name.joy: -------------------------------------------------------------------------------- 1 | (* 2 | module : name.joy 3 | version : 1.2 4 | date : 08/20/22 5 | *) 6 | DEFINE last == dup rest null [first] [rest last] branch. 7 | 8 | [pop] first name "pop" =. 9 | [last] first name "last" =. 10 | true name " truth value type" =. 11 | 'A name " character type" =. 12 | 10 name " integer type" =. 13 | {} name " set type" =. 14 | "" name " string type" =. 15 | [] name " list type" =. 16 | -------------------------------------------------------------------------------- /test2/neql.joy: -------------------------------------------------------------------------------- 1 | (* 2 | module : neql.joy 3 | version : 1.3 4 | date : 05/23/23 5 | *) 6 | 10 11 !=. 7 | 10 10 != false =. 8 | 10 9 !=. 9 | "ustu" "test" !=. 10 | [ustu] first "test" !=. 11 | [ustu] first [test] first !=. 12 | "ustu" [test] first !=. 13 | [ustu] first "test" !=. 14 | -------------------------------------------------------------------------------- /test2/not.joy: -------------------------------------------------------------------------------- 1 | (* 2 | module : not.joy 3 | version : 1.4 4 | date : 05/23/23 5 | *) 6 | true not false =. 7 | false not. 8 | -------------------------------------------------------------------------------- /test2/null.joy: -------------------------------------------------------------------------------- 1 | (* 2 | module : null.joy 3 | version : 1.2 4 | date : 08/20/22 5 | *) 6 | DEFINE last == dup rest null [first] [rest last] branch. 7 | 8 | [pop] first null false =. 9 | [last] first null false =. 10 | false null. 11 | true null false =. 12 | '\000 null. 13 | 'A null false =. 14 | 0 null. 15 | 10 null false =. 16 | {} null. 17 | {1 2 3} null false =. 18 | "" null. 19 | "test" null false =. 20 | [] null. 21 | [1 2 3] null false =. 22 | -------------------------------------------------------------------------------- /test2/nullary.joy: -------------------------------------------------------------------------------- 1 | (* 2 | module : nullary.joy 3 | version : 1.4 4 | date : 05/23/23 5 | *) 6 | "../lib/inilib.joy" include. 7 | "../lib/numlib.joy" include. 8 | "../lib/agglib.joy" include. 9 | 10 | 2 20 from-to-list dup [prime] map zip [second] filter [first] map 11 | [2 3 5 7 11 13 17 19] equal. 12 | 13 | [] unstack. 14 | 15 | 2 20 [] nullary stack [20 20 2] equal. 16 | -------------------------------------------------------------------------------- /test2/of.joy: -------------------------------------------------------------------------------- 1 | (* 2 | module : of.joy 3 | version : 1.2 4 | date : 08/20/22 5 | *) 6 | 2 [4 5 6] of 6 =. 7 | 2 "test" of 's =. 8 | 2 {4 5 6} of 6 =. 9 | -------------------------------------------------------------------------------- /test2/opcase.joy: -------------------------------------------------------------------------------- 1 | (* 2 | module : opcase.joy 3 | version : 1.3 4 | date : 05/23/23 5 | *) 6 | DEFINE test == [['A "ischar"] 7 | [pop "ispop"] 8 | [10 "isinteger"] 9 | ["isother"]] opcase i. 10 | 11 | 'A test "ischar" =. 12 | 10 test "isinteger" =. 13 | [test] first test "isother" =. 14 | [pop] first test "ispop" =. 15 | 16 | DEFINE test == [['A "ischar" "ischar"] 17 | [pop "ispop" "ispop"] 18 | [10 "isinteger" "isinteger"] 19 | ["isother" "isother"]] opcase i. 20 | 21 | 10 test "isinteger" =. 22 | -------------------------------------------------------------------------------- /test2/or.joy: -------------------------------------------------------------------------------- 1 | (* 2 | module : or.joy 3 | version : 1.2 4 | date : 08/20/22 5 | *) 6 | false false or false =. 7 | false true or. 8 | true false or. 9 | true true or. 10 | {1 2 3} {4 5 6} or {1 2 3 4 5 6} =. 11 | {1 2 3} {2 3 4} or {1 2 3 4} =. 12 | -------------------------------------------------------------------------------- /test2/pop.joy: -------------------------------------------------------------------------------- 1 | (* 2 | module : pop.joy 3 | version : 1.2 4 | date : 08/20/22 5 | *) 6 | 1 2 pop 1 =. 7 | -------------------------------------------------------------------------------- /test2/popd.joy: -------------------------------------------------------------------------------- 1 | (* 2 | module : popd.joy 3 | version : 1.2 4 | date : 08/20/22 5 | *) 6 | 1 2 popd 2 =. 7 | -------------------------------------------------------------------------------- /test2/pred.joy: -------------------------------------------------------------------------------- 1 | (* 2 | module : pred.joy 3 | version : 1.2 4 | date : 08/20/22 5 | *) 6 | 'A pred '@ =. 7 | 1 pred 0 =. 8 | -------------------------------------------------------------------------------- /test2/primrec.joy: -------------------------------------------------------------------------------- 1 | (* 2 | module : primrec.joy 3 | version : 1.2 4 | date : 08/20/22 5 | *) 6 | [1 2 3 4 5] [0] [+] primrec 15 =. 7 | 5 [1] [*] primrec 120 =. 8 | "test" [""] [cons] primrec "test" =. 9 | {1 2 3} [{}] [cons] primrec {1 2 3} =. 10 | # 'A [] [] primrec. 11 | -------------------------------------------------------------------------------- /test2/put.joy: -------------------------------------------------------------------------------- 1 | (* 2 | module : put.joy 3 | version : 1.2 4 | date : 08/20/22 5 | *) 6 | DEFINE last == dup rest null [first] [rest last] branch; 7 | nl == '\n putch. 8 | 9 | [pop] first put nl. 10 | [last] first put nl. 11 | true put nl. 12 | 'A put nl. 13 | 10 put nl. 14 | {1 2 3} put nl. 15 | "test" put nl. 16 | [1 2 3] put nl. 17 | 3.14 put nl. 18 | stdin put nl. 19 | -------------------------------------------------------------------------------- /test2/putch.joy: -------------------------------------------------------------------------------- 1 | (* 2 | module : putch.joy 3 | version : 1.2 4 | date : 08/20/22 5 | *) 6 | 'A putch '\n putch. 7 | -------------------------------------------------------------------------------- /test2/quit.joy: -------------------------------------------------------------------------------- 1 | (* 2 | module : quit.joy 3 | version : 1.2 4 | date : 08/20/22 5 | *) 6 | quit. 7 | -------------------------------------------------------------------------------- /test2/rem.joy: -------------------------------------------------------------------------------- 1 | (* 2 | module : rem.joy 3 | version : 1.3 4 | date : 05/23/23 5 | *) 6 | 54 24 rem 6 =. 7 | -------------------------------------------------------------------------------- /test2/rest.joy: -------------------------------------------------------------------------------- 1 | (* 2 | module : rest.joy 3 | version : 1.2 4 | date : 08/20/22 5 | *) 6 | [1 2 3] rest [2 3] equal. 7 | "test" rest "est" =. 8 | {1 2 3} rest {2 3} =. 9 | -------------------------------------------------------------------------------- /test2/rolldown.joy: -------------------------------------------------------------------------------- 1 | (* 2 | module : rolldown.joy 3 | version : 1.2 4 | date : 08/20/22 5 | *) 6 | 1 2 3 rolldown stack [1 3 2] equal. 7 | -------------------------------------------------------------------------------- /test2/rolldownd.joy: -------------------------------------------------------------------------------- 1 | (* 2 | module : rolldownd.joy 3 | version : 1.2 4 | date : 08/20/22 5 | *) 6 | 1 2 3 4 rolldownd stack [4 1 3 2] equal. 7 | -------------------------------------------------------------------------------- /test2/rollup.joy: -------------------------------------------------------------------------------- 1 | (* 2 | module : rollup.joy 3 | version : 1.2 4 | date : 08/20/22 5 | *) 6 | 1 2 3 rollup stack [2 1 3] equal. 7 | -------------------------------------------------------------------------------- /test2/rollupd.joy: -------------------------------------------------------------------------------- 1 | (* 2 | module : rollupd.joy 3 | version : 1.2 4 | date : 08/20/22 5 | *) 6 | 1 2 3 4 rollupd stack [4 2 1 3] equal. 7 | -------------------------------------------------------------------------------- /test2/rotate.joy: -------------------------------------------------------------------------------- 1 | (* 2 | module : rotate.joy 3 | version : 1.2 4 | date : 08/20/22 5 | *) 6 | 1 2 3 rotate stack [1 2 3] equal. 7 | -------------------------------------------------------------------------------- /test2/rotated.joy: -------------------------------------------------------------------------------- 1 | (* 2 | module : rotated.joy 3 | version : 1.2 4 | date : 08/20/22 5 | *) 6 | 1 2 3 4 rotated stack [4 1 2 3] equal. 7 | -------------------------------------------------------------------------------- /test2/set.joy: -------------------------------------------------------------------------------- 1 | (* 2 | module : set.joy 3 | version : 1.2 4 | date : 08/20/22 5 | *) 6 | {1 2 3} set. 7 | 10 set false =. 8 | -------------------------------------------------------------------------------- /test2/setautoput.joy: -------------------------------------------------------------------------------- 1 | (* 2 | module : setautoput.joy 3 | version : 1.2 4 | date : 08/20/22 5 | *) 6 | 1 setautoput. 7 | autoput 1 =. 8 | 0 1 2 3 4 5 6 7 8 9 10 10 =. 9 | 2 setautoput 10 | autoput 2 = put abort. 11 | -------------------------------------------------------------------------------- /test2/setecho.joy: -------------------------------------------------------------------------------- 1 | (* 2 | module : setecho.joy 3 | version : 1.2 4 | date : 08/20/22 5 | *) 6 | 1 setecho. 7 | echo 1 =. 8 | 2 setecho. 9 | echo 2 =. 10 | 3 setecho. 11 | echo 3 =. 12 | -------------------------------------------------------------------------------- /test2/setsize.joy: -------------------------------------------------------------------------------- 1 | (* 2 | module : setsize.joy 3 | version : 1.2 4 | date : 08/20/22 5 | *) 6 | setsize 32 =. 7 | -------------------------------------------------------------------------------- /test2/sign.joy: -------------------------------------------------------------------------------- 1 | (* 2 | module : sign.joy 3 | version : 1.3 4 | date : 05/23/23 5 | *) 6 | 2 sign 1 =. 7 | 0 sign 0 =. 8 | -------------------------------------------------------------------------------- /test2/size.joy: -------------------------------------------------------------------------------- 1 | (* 2 | module : size.joy 3 | version : 1.2 4 | date : 08/20/22 5 | *) 6 | [1 2 3] size 3 =. 7 | "test" size 4 =. 8 | {1 2 3} size 3 =. 9 | [] size null. 10 | "" size null. 11 | {} size null. 12 | -------------------------------------------------------------------------------- /test2/small.joy: -------------------------------------------------------------------------------- 1 | (* 2 | module : small.joy 3 | version : 1.2 4 | date : 08/20/22 5 | *) 6 | [] small. 7 | [1] small. 8 | [1 2] small false =. 9 | "" small. 10 | "t" small. 11 | "test" small false =. 12 | {} small. 13 | {1} small. 14 | {1 2} small false =. 15 | 0 small. 16 | 1 small. 17 | 2 small false =. 18 | -------------------------------------------------------------------------------- /test2/some.joy: -------------------------------------------------------------------------------- 1 | (* 2 | module : some.joy 3 | version : 1.3 4 | date : 05/23/23 5 | *) 6 | [1 2 3] [2 <] some. 7 | [1 2 3] [4 <] some. 8 | [1 2 3] [1 <] some false =. 9 | {1 2 3} [2 <] some. 10 | {1 2 3} [4 <] some. 11 | {1 2 3} [1 <] some false =. 12 | "test" ['t <] some. 13 | "test" ['u <] some. 14 | "test" ['e <] some false =. 15 | 16 | [] [2 <] some false =. 17 | "" ['t <] some false =. 18 | {} [2 <] some false =. 19 | 20 | [1 2 3] [] some. 21 | "test" [] some. 22 | {1 2 3} [] some. 23 | -------------------------------------------------------------------------------- /test2/split.joy: -------------------------------------------------------------------------------- 1 | (* 2 | module : split.joy 3 | version : 1.3 4 | date : 05/23/23 5 | *) 6 | [1 2 3 4 5 6 7 8 9] [5 <] split stack [[5 6 7 8 9] [1 2 3 4]] equal. 7 | pop pop "test" ['t <] split stack ["tt" "es"] equal. 8 | pop pop {1 2 3} [2 <] split stack [{2 3} {1}] equal. 9 | 10 | [] unstack. 11 | [] [2 <] split stack [[] []] equal. 12 | [] unstack. 13 | "" ['t <] split stack ["" ""] equal. 14 | [] unstack. 15 | {} [2 <] split stack [{} {}] equal. 16 | 17 | [] unstack. 18 | [1 2 3] [] split stack [[] [1 2 3]] equal. 19 | [] unstack. 20 | "test" [] split stack ["" "test"] equal. 21 | [] unstack. 22 | {1 2 3} [] split stack [{} {1 2 3}] equal. 23 | -------------------------------------------------------------------------------- /test2/stack.joy: -------------------------------------------------------------------------------- 1 | (* 2 | module : stack.joy 3 | version : 1.2 4 | date : 08/20/22 5 | *) 6 | 1 2 3 stack [3 2 1] equal. 7 | -------------------------------------------------------------------------------- /test2/step.joy: -------------------------------------------------------------------------------- 1 | (* 2 | module : step.joy 3 | version : 1.4 4 | date : 05/23/23 5 | *) 6 | 0 [1 2 3] [+] step 6 =. 7 | 0 "test" [swap + ord] step 448 =. 8 | 0 {1 2 3} [+] step 6 =. 9 | 10 | 1 [] [+] step 1 =. 11 | 2 "" [swap + ord] step 2 =. 12 | 3 {} [+] step 3 =. 13 | 14 | 0 [1 2 3] [] step 3 =. 15 | 0 "test" [] step 't =. 16 | 0 {1 2 3} [] step 3 =. 17 | -------------------------------------------------------------------------------- /test2/string.joy: -------------------------------------------------------------------------------- 1 | (* 2 | module : string.joy 3 | version : 1.2 4 | date : 08/20/22 5 | *) 6 | "test" string. 7 | 10 string false =. 8 | -------------------------------------------------------------------------------- /test2/sub.joy: -------------------------------------------------------------------------------- 1 | (* 2 | module : sub.joy 3 | version : 1.3 4 | date : 05/23/23 5 | *) 6 | 2 3 - -1 =. 7 | -------------------------------------------------------------------------------- /test2/succ.joy: -------------------------------------------------------------------------------- 1 | (* 2 | module : succ.joy 3 | version : 1.2 4 | date : 08/20/22 5 | *) 6 | 'A succ 'B =. 7 | 2 succ 3 =. 8 | -------------------------------------------------------------------------------- /test2/swap.joy: -------------------------------------------------------------------------------- 1 | (* 2 | module : swap.joy 3 | version : 1.2 4 | date : 08/20/22 5 | *) 6 | 1 2 swap stack [1 2] equal. 7 | -------------------------------------------------------------------------------- /test2/swapd.joy: -------------------------------------------------------------------------------- 1 | (* 2 | module : swapd.joy 3 | version : 1.2 4 | date : 08/20/22 5 | *) 6 | 1 2 3 swapd stack [3 1 2] equal. 7 | -------------------------------------------------------------------------------- /test2/swons.joy: -------------------------------------------------------------------------------- 1 | (* 2 | module : swons.joy 3 | version : 1.2 4 | date : 08/20/22 5 | *) 6 | [2 3] 1 swons [1 2 3] equal. 7 | "est" 't swons "test" =. 8 | {2 3} 1 swons {1 2 3} =. 9 | -------------------------------------------------------------------------------- /test2/system.joy: -------------------------------------------------------------------------------- 1 | (* 2 | module : system.joy 3 | version : 1.2 4 | date : 08/20/22 5 | *) 6 | "ls" system. 7 | -------------------------------------------------------------------------------- /test2/tailrec.joy: -------------------------------------------------------------------------------- 1 | (* 2 | module : tailrec.joy 3 | version : 1.2 4 | date : 08/20/22 5 | *) 6 | [] 0 [10 =] [pop] [dup [swons] dip succ] tailrec [9 8 7 6 5 4 3 2 1 0] equal. 7 | -------------------------------------------------------------------------------- /test2/take.joy: -------------------------------------------------------------------------------- 1 | (* 2 | module : take.joy 3 | version : 1.5 4 | date : 05/23/23 5 | *) 6 | [1 2 3] 2 take [1 2] equal. 7 | [1 2 3] 5 take [1 2 3] equal. 8 | "test" 2 take "te" =. 9 | "test" 5 take "test" =. 10 | {1 2 3} 2 take {1 2} =. 11 | {1 2 3} 5 take {1 2 3} =. 12 | -------------------------------------------------------------------------------- /test2/ternary.joy: -------------------------------------------------------------------------------- 1 | (* 2 | module : ternary.joy 3 | version : 1.3 4 | date : 05/23/23 5 | *) 6 | 1 2 3 4 5 [+] ternary stack [9 2 1] equal. 7 | 8 | [] unstack. 9 | 1 2 3 4 5 [] ternary stack [5 2 1] equal. 10 | -------------------------------------------------------------------------------- /test2/times.joy: -------------------------------------------------------------------------------- 1 | (* 2 | module : times.joy 3 | version : 1.3 4 | date : 05/23/23 5 | *) 6 | DEFINE fib == [1 0] dip [swap [+] unary] times popd. 7 | 8 | 10 fib 55 =. 9 | 10 | 1 10 [] times 1 =. 11 | 12 | 1 0 [succ] times 1 =. 13 | -------------------------------------------------------------------------------- /test2/treegenrec.joy: -------------------------------------------------------------------------------- 1 | (* 2 | module : treegenrec.joy 3 | version : 1.2 4 | date : 08/20/22 5 | *) 6 | DEFINE treemap == [] [map] treegenrec; 7 | treesample == [[1 2 [3 4] 5 [[[6]]] 7] 8]. 8 | 9 | 0 treesample [[dup] dip -] treemap [[-1 -2 [-3 -4] -5 [[[-6]]] -7] -8] equal. 10 | -------------------------------------------------------------------------------- /test2/treerec.joy: -------------------------------------------------------------------------------- 1 | (* 2 | module : treerec.joy 3 | version : 1.2 4 | date : 08/20/22 5 | *) 6 | DEFINE treesample == [[1 2 [3 4] 5 [[[6]]] 7] 8]. 7 | 8 | treesample [dup *] [map] treerec [[1 4 [9 16] 25 [[[36]]] 49] 64] equal. 9 | -------------------------------------------------------------------------------- /test2/treestep.joy: -------------------------------------------------------------------------------- 1 | (* 2 | module : treestep.joy 3 | version : 1.2 4 | date : 08/20/22 5 | *) 6 | DEFINE treesample == [[1 2 [3 4] 5 [[[6]]] 7] 8]. 7 | 8 | [] treesample [swons] treestep [8 7 6 5 4 3 2 1] equal. 9 | -------------------------------------------------------------------------------- /test2/true.joy: -------------------------------------------------------------------------------- 1 | (* 2 | module : true.joy 3 | version : 1.2 4 | date : 08/20/22 5 | *) 6 | "true" intern [] cons i. 7 | -------------------------------------------------------------------------------- /test2/unary.joy: -------------------------------------------------------------------------------- 1 | (* 2 | module : unary.joy 3 | version : 1.3 4 | date : 05/23/23 5 | *) 6 | DEFINE fib == [1 0] dip [swap [+] unary] times popd. 7 | 8 | 10 fib 55 =. 9 | 10 | 2 20 [] unary stack [20 2] equal. 11 | -------------------------------------------------------------------------------- /test2/uncons.joy: -------------------------------------------------------------------------------- 1 | (* 2 | module : uncons.joy 3 | version : 1.2 4 | date : 08/20/22 5 | *) 6 | [1 2 3] uncons stack [[2 3] 1] equal. 7 | pop pop "test" uncons stack ["est" 't] equal. 8 | pop pop {1 2 3} uncons stack [{2 3} 1] equal. 9 | -------------------------------------------------------------------------------- /test2/unstack.joy: -------------------------------------------------------------------------------- 1 | (* 2 | module : unstack.joy 3 | version : 1.2 4 | date : 08/20/22 5 | *) 6 | [1 2 3] unstack 7 | 1 =. 8 | 2 =. 9 | 3 =. 10 | -------------------------------------------------------------------------------- /test2/unswons.joy: -------------------------------------------------------------------------------- 1 | (* 2 | module : unswons.joy 3 | version : 1.3 4 | date : 05/23/23 5 | *) 6 | [1 2 3] unswons 7 | 1 =. 8 | [2 3] equal. 9 | "test" unswons 10 | 't =. 11 | "est" =. 12 | {1 2 3} unswons 13 | 1 =. 14 | {2 3} =. 15 | 16 | [1] unswons. 17 | -------------------------------------------------------------------------------- /test2/user.joy: -------------------------------------------------------------------------------- 1 | (* 2 | module : user.joy 3 | version : 1.2 4 | date : 08/20/22 5 | *) 6 | DEFINE last == dup rest null [first] [rest last] branch. 7 | 8 | [last] first user. 9 | [pop] first user false =. 10 | -------------------------------------------------------------------------------- /test2/while.joy: -------------------------------------------------------------------------------- 1 | (* 2 | module : while.joy 3 | version : 1.2 4 | date : 08/20/22 5 | *) 6 | DEFINE prime == 2 [[[dup * >] nullary [rem 0 >] dip and] nullary] [succ] 7 | while dup * <. 8 | 9 | 19 prime. 10 | -------------------------------------------------------------------------------- /test2/x.joy: -------------------------------------------------------------------------------- 1 | (* 2 | module : x.joy 3 | version : 1.3 4 | date : 05/23/23 5 | *) 6 | DEFINE test == [pop succ] x. 7 | 8 | 2 test 3 =. 9 | 10 | 2 [] x stack [[] 2] equal. 11 | -------------------------------------------------------------------------------- /test2/xor.joy: -------------------------------------------------------------------------------- 1 | (* 2 | module : xor.joy 3 | version : 1.2 4 | date : 08/20/22 5 | *) 6 | false false xor false =. 7 | false true xor. 8 | true false xor. 9 | true true xor false =. 10 | {1 2 3} {4 5 6} xor {1 2 3 4 5 6} =. 11 | {1 2 3} {2 3 4} xor {1 4} =. 12 | -------------------------------------------------------------------------------- /usrlib.joy: -------------------------------------------------------------------------------- 1 | (* FILE: usrlib.joy - if it exists, then it is loaded by default *) 2 | 3 | LIBRA 4 | 5 | RAWJOY1 == "the primitives of the Joy1 system\n"; 6 | _usrlib == true; 7 | putchars == [putch] step; 8 | 9 | (* personalise: 10 | myname == "Abigail Aardvark"; 11 | myphone == 12345678; 12 | etc *) 13 | 14 | HIDE 15 | returned == "\007\nReturned to Joy\n" putchars 16 | IN 17 | (* unix: *) 18 | unix == true; 19 | control-eof == 'D; 20 | terminal == "/dev/tty"; 21 | ls == "ls -la" system; 22 | editor == "vi "; 23 | escape == 24 | "\nTo return to Joy, type: exit\n" putchars 25 | "csh" system 26 | returned; 27 | (* etc *) 28 | 29 | (* vms: 30 | vms == true; 31 | control-eof == 'Z; 32 | terminal == "tt:"; 33 | dir == "DIR/DATE" system returned; 34 | editor == "TECO "; 35 | escape == 36 | "\nTo return to Joy, hit Control-" putchars 37 | control-eof putch '\n putch 38 | "@tt:" system 39 | returned; 40 | etc *) 41 | 42 | edit == 43 | dup editor swap concat system 44 | dup "Including " putchars putchars '\n putch 45 | include 46 | returned; 47 | 48 | find-in == 49 | [ [ [ [unix] first body null not ] 50 | " " swap concat concat "grep " swap concat system ] 51 | [ [ [vms] first body null not ] 52 | swap " " swap concat concat "SEARCH " swap concat system ] 53 | [ "unknown operating system for find-in\n" putchars ] ] 54 | cond 55 | returned; 56 | standard-setting == 1 setautoput (* 1 setundeferror *); 57 | USRLIB == "usrlib.joy - (personal) user library\n" 58 | 59 | END . (* end HIDE and LIBRA *) 60 | 61 | (* demo: 62 | "library" "*.joy" find-in. 63 | etc *) 64 | 65 | "usrlib is loaded\n" putchars. 66 | 67 | standard-setting. 68 | 69 | "inilib.joy" include. 70 | (* assuming inilib.joy was included: *) 71 | "agglib.joy" include. 72 | (* "numlib.joy" include. *) 73 | 74 | (* show-todaynow. *) 75 | 76 | DEFINE verbose == true. (* Example of over-riding inilib.joy *) 77 | 78 | (* END usrlib.joy *) 79 | -------------------------------------------------------------------------------- /utils.c: -------------------------------------------------------------------------------- 1 | /* 2 | module : utils.c 3 | version : 1.1.1.3 4 | date : 12/16/24 5 | */ 6 | #include 7 | #include 8 | #include "globals.h" 9 | 10 | #define CORRECT_GARBAGE_COLLECTOR 11 | 12 | /* PUBLIC int clock(); */ /* file time.h */ 13 | PUBLIC void getsym(); /* file scan.c */ 14 | PUBLIC void error(char *message); 15 | PUBLIC void execerror(char *message, char *op); /* file main.c */ 16 | PUBLIC void lookup(); 17 | /* PUBLIC void exit(); */ /* file interp.c */ 18 | 19 | static Node 20 | memory[MEMORYMAX], 21 | *memoryindex = memory, 22 | *mem_low = memory, 23 | *mem_mid; 24 | #define MEM_HIGH (MEMORYMAX-1) 25 | static int direction = +1; 26 | static int nodesinspected, nodescopied; 27 | static int start_gc_clock; 28 | 29 | PUBLIC void inimem1() 30 | { 31 | stk = conts = dump = dump1 = dump2 = dump3 = dump4 = dump5 = NULL; 32 | direction = +1; 33 | memoryindex = mem_low; 34 | } 35 | PUBLIC void inimem2() 36 | { 37 | mem_low = memoryindex; 38 | #ifdef CORRECT_GARBAGE_COLLECTOR 39 | mem_mid = mem_low + (&memory[MEM_HIGH] - mem_low) / 2; 40 | #else 41 | mem_mid = mem_low + (MEM_HIGH)/2; 42 | #endif 43 | if (tracegc > 1) 44 | { printf("memory = %ld : %ld\n", 45 | (long)memory,MEM2INT(memory)); 46 | printf("memoryindex = %ld : %ld\n", 47 | (long)memoryindex,MEM2INT(memoryindex)); 48 | printf("mem_low = %ld : %ld\n", 49 | (long)mem_low,MEM2INT(mem_low)); 50 | printf("top of mem = %ld : %ld\n", 51 | (long)(&memory[MEM_HIGH]),MEM2INT((&memory[MEM_HIGH]))); 52 | printf("mem_mid = %ld : %ld\n", 53 | (long)mem_mid,MEM2INT(mem_mid)); } 54 | } 55 | PUBLIC void printnode(p) 56 | Node *p; 57 | { 58 | printf("%10ld: %-10s %10ld %10ld\n", 59 | MEM2INT(p), 60 | symtab[(short) p->op].name, 61 | p->op == LIST_ ? MEM2INT(p->u.lis) : p->u.num, 62 | MEM2INT(p->next)); 63 | } 64 | PRIVATE Node *copy(n) 65 | Node *n; 66 | { 67 | Node *temp; 68 | nodesinspected++; 69 | if (tracegc > 4) printf("copy ..\n"); 70 | if (n == NULL) return NULL; 71 | if (n < mem_low) return n; /* later: combine with previous line */ 72 | if (n->op == ILLEGAL_) 73 | { printf("copy: illegal node "); printnode(n); return(NULL); } 74 | if (n->op == COPIED_) return n->u.lis; 75 | temp = memoryindex; memoryindex += direction; 76 | temp->op = n->op; 77 | temp->u.num = n->op == LIST_ ? (long)copy(n->u.lis) : n->u.num; 78 | temp->next = copy(n->next); 79 | n->op = COPIED_; 80 | n->u.lis = temp; 81 | nodescopied++; 82 | if (tracegc > 3) 83 | { printf("%5d - ",nodescopied); printnode(temp); } 84 | return temp; 85 | } 86 | PUBLIC void writeterm(Node *n); 87 | 88 | PUBLIC void gc1(mess) 89 | char * mess; 90 | { 91 | start_gc_clock = clock(); 92 | if (tracegc > 1) 93 | printf("begin %s garbage collection\n",mess); 94 | direction = - direction; 95 | memoryindex = (direction == 1) ? mem_low : &memory[MEM_HIGH]; 96 | /* 97 | if (tracegc > 1) 98 | { printf("direction = %d\n",direction); 99 | printf("memoryindex = %d : %d\n", 100 | (long)memoryindex,MEM2INT(memoryindex)); } 101 | */ 102 | nodesinspected = nodescopied = 0; 103 | 104 | #define COP(X,NAME) \ 105 | if (X != NULL) \ 106 | { if (tracegc > 2) \ 107 | { printf("old %s = ",NAME); \ 108 | writeterm(X); printf("\n"); } \ 109 | X = copy(X); \ 110 | if (tracegc > 2) \ 111 | { printf("new %s = ",NAME); \ 112 | writeterm(X); printf("\n"); } } 113 | 114 | COP(stk,"stk"); COP(prog,"prog"); COP(conts,"conts"); 115 | COP(dump,"dump"); COP(dump1,"dump1"); COP(dump2,"dump2"); 116 | COP(dump3,"dump3"); COP(dump4,"dump4"); COP(dump5,"dump5"); 117 | } 118 | PRIVATE void gc2(mess) 119 | char * mess; 120 | { 121 | int this_gc_clock; 122 | this_gc_clock = clock() - start_gc_clock; 123 | if (this_gc_clock == 0) this_gc_clock = 1; /* correction */ 124 | if (tracegc > 0) 125 | printf("gc - %d nodes inspected, %d nodes copied, clock: %d\n", 126 | nodesinspected,nodescopied,this_gc_clock); 127 | if (tracegc > 1) 128 | printf("end %s garbage collection\n",mess); 129 | gc_clock += this_gc_clock; 130 | } 131 | PUBLIC void gc_() 132 | { 133 | gc1("user requested"); 134 | gc2("user requested"); 135 | } 136 | PUBLIC Node *newnode(o,l,r) 137 | Operator o; 138 | long l; 139 | Node *r; 140 | { 141 | Node *p; 142 | if (memoryindex == mem_mid) 143 | { gc1("automatic"); 144 | if (o == LIST_) l = (long)copy(l); 145 | r = copy(r); 146 | #ifdef CORRECT_GARBAGE_COLLECTOR 147 | gc2("automatic"); 148 | if ((direction == +1 && memoryindex >= mem_mid) || 149 | (direction == -1 && memoryindex <= mem_mid)) 150 | execerror("memory", "copying"); } 151 | #else 152 | gc2("automatic"); } 153 | #endif 154 | p = memoryindex; 155 | memoryindex += direction; 156 | p->op = o; 157 | p->u.num = l; 158 | p->next = r; 159 | D( printnode(p); ) 160 | return p; 161 | } 162 | PUBLIC void memoryindex_() 163 | { 164 | stk = newnode(INTEGER_,MEM2INT(memoryindex),stk); 165 | } 166 | PUBLIC void readfactor() /* read a JOY factor */ 167 | { 168 | switch (sym) 169 | { case ATOM: 170 | lookup(); 171 | D( printf("readfactor: location = %ld\n",(long) location); ) 172 | if (location < firstlibra) 173 | stk = newnode(LOC2INT(location),location->u.proc,stk); 174 | else stk = newnode(USR_,location,stk); 175 | return; 176 | case INTEGER_: case CHAR_: case STRING_: 177 | stk = newnode(sym,num,stk); 178 | return; 179 | case LBRACE: 180 | { int set = 0; getsym(); 181 | while (sym != RBRACE) 182 | { if (sym == CHAR_ || sym == INTEGER_) 183 | set = set | (1 << num); 184 | else error("numeric expected in set"); 185 | getsym(); } 186 | stk = newnode(SET_,set,stk); } 187 | return; 188 | case LBRACK: 189 | { void readterm(); 190 | getsym(); 191 | readterm(); 192 | if (sym != RBRACK) 193 | error("']' expected"); 194 | return; } 195 | /* MU - MU x IN --x--x-- . 196 | stk = newnode(MU, 197 | newnode(IN, entry to x, body), stk); 198 | return; 199 | */ 200 | default: 201 | error("a factor cannot begin with this symbol"); 202 | return; } 203 | } 204 | PUBLIC void readterm() 205 | { 206 | stk = newnode(LIST_,NULL,stk); 207 | if (sym <= ATOM) 208 | { readfactor(); 209 | stk->next->u.lis = stk; 210 | stk = stk->next; 211 | stk->u.lis->next = NULL; 212 | dump = newnode(LIST_,stk->u.lis,dump); 213 | getsym(); 214 | while (sym <= ATOM) 215 | { readfactor(); 216 | dump->u.lis->next = stk; 217 | stk = stk->next; 218 | dump->u.lis->next->next = NULL; 219 | dump->u.lis = dump->u.lis->next; 220 | getsym(); } 221 | dump = dump->next; } 222 | } 223 | 224 | PUBLIC void writefactor(n) 225 | Node *n; 226 | { 227 | if (n == NULL) 228 | #ifdef DEBUG 229 | return; 230 | #else 231 | execerror("non-empty stack","print"); 232 | #endif 233 | switch (n->op) 234 | { case BOOLEAN_: 235 | printf("%s", n->u.num ? "true" : "false"); return; 236 | case INTEGER_: 237 | printf("%ld",n->u.num); return; 238 | case SET_: 239 | { int i; long set = n->u.set; 240 | printf("{"); 241 | for (i = 0; i < SETSIZE; i++) 242 | if (set & (1 << i)) 243 | { printf("%d",i); 244 | set = set & ~(1 << i); 245 | if (set != 0) 246 | printf(" "); } 247 | printf("}"); 248 | return; } 249 | case CHAR_: 250 | printf("'%c", (char) n->u.num); return; 251 | case STRING_: 252 | printf("\"%s\"",n->u.str); return; 253 | case LIST_: 254 | printf("%s","["); 255 | writeterm(n->u.lis); 256 | printf("%s","]"); 257 | return; 258 | case USR_: 259 | printf("%s", n->u.ent->name ); return; 260 | default: 261 | printf("%s",symtab[(int) n->op].name); return; } 262 | } 263 | PUBLIC void writeterm(n) 264 | Node *n; 265 | { 266 | while (n != NULL) 267 | { 268 | writefactor(n); 269 | n = n->next; 270 | if (n != NULL) 271 | printf(" "); 272 | } 273 | } 274 | --------------------------------------------------------------------------------