From 16f78f40779c48af73603a2d62ea85c63c8c1eb1 Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Mon, 19 Jul 2021 10:57:22 +0100 Subject: [PATCH 01/28] Print output for lambda and nlambda cells was misleading. --- src/io/print.c | 8 ++++++-- 1 file changed, 6 insertions(+), 2 deletions(-) diff --git a/src/io/print.c b/src/io/print.c index f0db8cd..c68c03e 100644 --- a/src/io/print.c +++ b/src/io/print.c @@ -183,8 +183,9 @@ struct cons_pointer print( URL_FILE * output, struct cons_pointer pointer ) { print_string_contents( output, pointer ); break; case LAMBDATV:{ + url_fputws( L"', output); } break; case NILTV: url_fwprintf( output, L"nil" ); break; case NLAMBDATV:{ + url_fputws( L"', output); } break; case RATIOTV: From d2101dbd473eff0984e540bd76b45cd4484803ff Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Sat, 24 Jul 2021 08:54:55 +0100 Subject: [PATCH 02/28] Started to try to get back into this; work on exceptions and loops. --- .vscode/settings.json | 7 ++++ src/memory/conspage.c | 2 +- src/memory/consspaceobject.c | 2 +- src/memory/consspaceobject.h | 25 +++++++++++--- src/memory/stack.c | 3 +- src/ops/exceptions.c | 62 +++++++++++++++++++++++++++++++++++ src/ops/lispops.c | 6 ++-- src/ops/lispops.h | 4 +++ utils_src/tagvalcalc/tvc | Bin 8544 -> 16848 bytes 9 files changed, 101 insertions(+), 10 deletions(-) create mode 100644 .vscode/settings.json create mode 100644 src/ops/exceptions.c diff --git a/.vscode/settings.json b/.vscode/settings.json new file mode 100644 index 0000000..14fb483 --- /dev/null +++ b/.vscode/settings.json @@ -0,0 +1,7 @@ +{ + "files.associations": { + "future": "cpp", + "system_error": "cpp", + "functional": "c" + } +} \ No newline at end of file diff --git a/src/memory/conspage.c b/src/memory/conspage.c index 2d0958d..53496d3 100644 --- a/src/memory/conspage.c +++ b/src/memory/conspage.c @@ -148,7 +148,7 @@ void free_cell( struct cons_pointer pointer ) { dec_ref( cell->payload.cons.cdr ); break; case EXCEPTIONTV: - dec_ref( cell->payload.exception.message ); + dec_ref( cell->payload.exception.payload ); dec_ref( cell->payload.exception.frame ); break; case FUNCTIONTV: diff --git a/src/memory/consspaceobject.c b/src/memory/consspaceobject.c index 344f4ae..98bb495 100644 --- a/src/memory/consspaceobject.c +++ b/src/memory/consspaceobject.c @@ -163,7 +163,7 @@ struct cons_pointer make_exception( struct cons_pointer message, inc_ref( message ); inc_ref( frame_pointer ); - cell->payload.exception.message = message; + cell->payload.exception.payload = message; cell->payload.exception.frame = frame_pointer; result = pointer; diff --git a/src/memory/consspaceobject.h b/src/memory/consspaceobject.h index 9197172..4b0500b 100644 --- a/src/memory/consspaceobject.h +++ b/src/memory/consspaceobject.h @@ -45,7 +45,8 @@ #define CONSTV 1397641027 /** - * An exception. + * An exception. TODO: we need a means of dealing with different classes of + * exception, and we don't have one yet. */ #define EXCEPTIONTAG "EXEP" @@ -108,6 +109,17 @@ */ #define LAMBDATV 1094995276 +/** + * A loop exit is a special kind of exception which has exactly the same + * payload as an exception. + */ +#define LOOPXTAG "LOOX" + +/** + * The string `LOOX`, considered as an `unsigned int`. + */ +#define LOOPXTV 1481592652 + /** * The special cons cell at address {0,0} whose car and cdr both point to * itself. @@ -286,10 +298,15 @@ #define keywordp(conspoint) (check_tag(conspoint,KEYTAG)) /** - * true if `conspoint` points to a special Lambda cell, else false + * true if `conspoint` points to a Lambda binding cell, else false */ #define lambdap(conspoint) (check_tag(conspoint,LAMBDATAG)) +/** + * true if `conspoint` points to a loop exit exception, else false. + */ +#define loopexitp(conspoint) (check_tag(conspoint,LOOPXTAG)) + /** * true if `conspoint` points to a special form cell, else false */ @@ -414,8 +431,8 @@ struct cons_payload { * Message should be a Lisp string; frame should be a pointer to an (unfreed) stack frame. */ struct exception_payload { - /** The message: should be a Lisp string but in practice anything printable will do. */ - struct cons_pointer message; + /** The payload: usually a Lisp string but in practice anything printable will do. */ + struct cons_pointer payload; /** pointer to the (unfreed) stack frame in which the exception was thrown. */ struct cons_pointer frame; }; diff --git a/src/memory/stack.c b/src/memory/stack.c index 3f4a271..d6d3c36 100644 --- a/src/memory/stack.c +++ b/src/memory/stack.c @@ -267,7 +267,8 @@ void dump_frame( URL_FILE * output, struct cons_pointer frame_pointer ) { void dump_stack_trace( URL_FILE * output, struct cons_pointer pointer ) { if ( exceptionp( pointer ) ) { - print( output, pointer2cell( pointer ).payload.exception.message ); + // todo: if the payload isn't a message, we maybe shouldn't print it? + print( output, pointer2cell( pointer ).payload.exception.payload ); url_fputws( L"\n", output ); dump_stack_trace( output, pointer2cell( pointer ).payload.exception.frame ); diff --git a/src/ops/exceptions.c b/src/ops/exceptions.c new file mode 100644 index 0000000..48c031f --- /dev/null +++ b/src/ops/exceptions.c @@ -0,0 +1,62 @@ + /* + * exceptions.c + * + * This is really, really unfinished and doesn't yet work. One of the really key + * things about exceptions is that the stack frames between the throw and the + * catch should not be derefed, so eval/apply will need to be substantially + * re-written. + * + * (c) 2021 Simon Brooke + * Licensed under GPL version 2.0, or, at your option, any later version. + */ + +#include +#include +#include +#include +#include + +#include "consspaceobject.h" +#include "conspage.h" +#include "debug.h" +#include "dump.h" +#include "equal.h" +#include "integer.h" +#include "intern.h" +#include "io.h" +#include "lispops.h" +#include "map.h" +#include "print.h" +#include "read.h" +#include "stack.h" +#include "vectorspace.h" + + +/** + * OK, the idea here (and I know this is less than perfect) is that the basic `try` + * function in PSSE takes two arguments, the first, `body`, being a list of forms, + * and the second, `catch`, being a catch handler (which is also a list of forms). + * Forms from `body` are evaluated in turn until one returns an exception object, + * or until the list is exhausted. If the list was exhausted, then the value of + * evaluating the last form in `body` is returned. If an exception was encountered, + * then each of the forms in `catch` is evaluated and the value of the last of + * those is returned. + * + * This is experimental. It almost certainly WILL change. + */ +struct cons_pointer lisp_try(struct stack_frame *frame, + struct cons_pointer frame_pointer, + struct cons_pointer env) +{ + struct cons_pointer result = c_progn(frame, frame_pointer, frame->arg[0], env); + + if (loopexitp(result)) + { + // TODO: need to put the exception into the environment! + result = c_progn(frame, frame_pointer, frame->arg[1], env); + } + + return result; +} + + diff --git a/src/ops/lispops.c b/src/ops/lispops.c index 4e2ddbf..8dd0109 100644 --- a/src/ops/lispops.c +++ b/src/ops/lispops.c @@ -107,7 +107,7 @@ struct cons_pointer eval_forms( struct stack_frame *frame, list = c_cdr( list ); } - return result; + return c_reverse( result); } /** @@ -991,7 +991,7 @@ c_progn( struct stack_frame *frame, struct cons_pointer frame_pointer, result = eval_form( frame, frame_pointer, c_car( expressions ), env ); dec_ref( r ); - expressions = c_cdr( expressions ); + expressions = exceptionp(result) ? NIL : c_cdr( expressions ); } return result; @@ -1259,7 +1259,7 @@ struct cons_pointer lisp_source( struct stack_frame *frame, case SPECIALTV: result = c_assoc( source_key, cell.payload.special.meta ); break; - case LAMBDATV: + case LAMBDATV: result = make_cons( c_string_to_lisp_symbol( L"lambda" ), make_cons( cell.payload.lambda.args, cell.payload.lambda.body ) ); diff --git a/src/ops/lispops.h b/src/ops/lispops.h index 122635f..f359252 100644 --- a/src/ops/lispops.h +++ b/src/ops/lispops.h @@ -29,6 +29,10 @@ struct cons_pointer c_reverse( struct cons_pointer arg ); +struct cons_pointer +c_progn( struct stack_frame *frame, struct cons_pointer frame_pointer, + struct cons_pointer expressions, struct cons_pointer env ); + /** * Useful building block; evaluate this single form in the context of this * parent stack frame and this environment. diff --git a/utils_src/tagvalcalc/tvc b/utils_src/tagvalcalc/tvc index a639364e1d9b231bea94f83e58fdd6378dcccd83..acd850a02231fc7f80d1516dc01c995fcc0d848b 100755 GIT binary patch literal 16848 zcmeHOeQZB$=-#PYs zFOI0H{kL}&``q(8ANSsK@4LP?@7`|*JKCHMhv4KAUlGVncyz>10?#(e0P%}vu^7JV z#DiiU@D&o%<$j%jR8Nd(3PEBjs2ylmi2~xS z^cK~VDa(uHdC?e>SAG|1H!474YP7?uj5SEH7~5{9161B1QMN-C?Z(M&oa~rRQ+Z4| zo){DSG*djS)C)39UimGA)$SnKS!pZjGsQA69k{MVK2Lf3$j;-HZiJO`IZU~{C%}%n zRyVxIH+S=XDsQfS=%)BHrSOXN@mSB6ruFeiLp+wu4mJ!nZ)w=lMq!kFQA0e+&%Zb`dh*u8l@@|vX&GS*FmD-r8DQn~*UW(j=D=S9+zTITdIW%S{=Wyf z*QyLWMtgM`TtNSXu{*YijFwJ@2Zn^IX0%ZFX*JycwAver#l=86mehJhA{39O!XOS0 zhSc6zG8B(J8wD0Uph;R&6QNjA?CNN5*{N>yH5GFkeVc{a-nm)bU|-ofAR;L>0XqVA1ndad5wIg*N8qzX;N$8C z|E&!Fqe>a6{L^|Nl$RznXJJwqK38>CIw)*@0pOWJ{V-5<70J50N^V*?^WhHV%x#zAIImp1tJQ#mSII$D;Yx3H9kh$>F+Rt) zqgZ4g=~9NbzkpdKcU@bgjBGyvOn&Nap^%S2aL!jA1>SKOY)$r4M?i>cq*Wt?d|nd*S(1Klj93VGKNo%^Ww;sV*AUEfE@ul0(J!K2-p#@BVb3s zj({BjI|BbV5y1CP^-aE}%(eyfk^5lxxytnzY|{k3Q}Ij}3WGqqfsO$k0E+v&aiHBm ze{iEvm;~BAQz%RWodnv9dre6A?h}*a+5N&X=y9xCG{5Q;$PmYO`U?1f4Y&}k^X03r zHIQwB|Jg?)&-J#FsV$Ez0}sX8uptlakSrZuY(M*BnXISqQ!5J5a_& z0XqVA1ndad5wIg*N5GDN9f8jh0Y2Zy=lN)RRXjVlh@H@82wu#|l&3?MD~RWFgR6+= zvwACu=ktTOU&6%lTXzd7G9fcD zM(6qP)iI`S`CZya@)^JT2_K+Ch>VX@#kk%Rq{n9ux%>wSXTARv^!7nqB?NCOWqXg4 zKX~&hd5$}5BPHKU@=u88c98r38R2u^R)>w$-+rR|h;|dT>fej!bD_I-?%d{G+trgz zYFY1A-zHyU!-hw*lHG7@W23LJX`K$=%OS{JFiLC71P0H+^7(Y58y8sc`ExT~A)YJi zr?NOM&HD3--E@b-{mE4wltlUObO%*8hUw`NWLh zFUpN)7t9X){G0V*_VODMJ?|1Lg{Lgevs=jqpW6y?qfkQh9L}3g=#*(oJl%wQ>HIX? zeTi_MhZ%nqG7dw1c%EpJ`0O~~VSOxj%;JAY>d%hnD}a})|6J{QRr;wBhp@tyRL;+D zrOxtM{dEp-hnU@8e;|GSJ>ep*$jt2V^D*Es3(V@@tIz_T#z0AF1O7vZ#)(Xw!& zCoD?0FjOs}hVdRo2JT=)Qfgm3)f0-V5iOO@sG;nj2&WPQ@u(J!_?jEHG?rJwyC5+& zlun0+)M!#m4~gD%C=pd7*+c?wlNdM^G&Pf|7V3K@6c586R7_Rd_6K$c)!?316|RAp zwIf1p{o0?2TK5ZeSI6F#K!>`wt?fXtQ|%12bOh0>ysr|@ zWM#ei){EcI*H-R%StS|?X(8}qz9my~&_owzN{Do6y(eQ8qgVY34EQ$RhfyP$l-eIk zM)0mo`(DtB#FA<@6NQ+RnuD>WOFCBHJ(&!-mN#@%6|UcKl<{6p*~>QOi#}$T!j~CJ zXrUgUT3V<5oP*0k(e!}uB~x0|*O$!t2GXg4Xj&UGKt0(QTnURs2nw{cH^4{`QoTQv z=@-7pP!fvJsg~9y&qULiSSo2^RFI{k@emqNZXm7+pNxhNvcA3)u$ak2!@{RU2Z6;Q z3)(5!mA+^{4buJycwyW`c z1aDV)oy_--t@_L}y#cn^Mz-gD)N2g@LSj9gEAfoq0RfI(w&(p8-zVpL<2Zj{Vmt2t zUjT+pWP9G1jnP7|8)U}B_Dtu2vC&@mNxM;}Tn_tSJLVUGF=AXkuOB^RZ`H@LjA;p# zPwGVx+do`H^bFe@DUThas-GNo)5P!q2z~J3`tbaV|8L^D8|}yNhY8YNi*qhlm*U#K Qy!}Vby2eV2frS*+?rA z9~=y-p^H%KV?r*$xs=jFjy<}xkWdUxa!C$4_>cq{8pzQUW97ZwS!=a!dvBQ!X6JkJ z%{7$gf-v9-@d1j3BIWtvGv+1p!q;qVwMZ-c zTST7c=qTlwIWgAS#T_4QZ4(M(Zeour>>;I{x@pt%EX=puiDVF3QgLFW)3n`Uz6r=z zv`dNNc2k%y0YS)jQ1$S!KcHRl?NtpPpG>E+GpPdF!hE*k8&Lg;sr$C=m|wDJ7c%*4 zszaD>N%0*}apIu0a3dgPDSsoApOTsU)oB;EuEzt#$2F%BhdI26cjda)QKTFh9vcos zuzoG;>aTBLU2)HCb4!`e%HnJ;F`bn&cHtlSd>Y;#9PbJb`If+~kEIk8<7iemrL%(KCc-N7atnp97#UfImS! zftvlOJ>!eO%rV+0#Cg*B$ckI`nJL{LQMez(wfwd}YPISxO{n6jhDpFDgn zgT~)w-i$GaJ&#@>jYxAYn9t~J(N5(CJ|DomG6{5o9YG=gcZQeOF@>p@Hm!hGKr5gX z&to^Ea#c!{82wehU#g)bXt`!5gljrNd=u9 z^YH^w=N{BCSHM_ajyPs*{a&NdsF<5p`SmKr5gX&Q``p8DnZWrl4zIr{h(%F|cE=?TwF~*=%&bhNud}fSjk(Eeb~;I90L|cx z+P(_pTSVgAewWOpW$I=sS+Y|&6Q3k)Uv4s!7cqXYXcNo5s=x2BxhvwG81ggCdoK3A zZ4mRD2Wq;moxnASPlhl*-UQ>`&w6L1{9geq9&9sk^1O4-NEUMr>EJ8i=e|QglD`E8 C{uSo{ From 70d176982b04709abd94a1b5e861e8c7b596a95b Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Sun, 25 Jul 2021 17:02:28 +0100 Subject: [PATCH 03/28] Work on exception handling, especially around ratio arithmetic Much simplified but will break things! --- .gitignore | 2 + lisp/defun.lisp | 5 ++ src/arith/integer.c | 35 ++++++++ src/arith/integer.h | 18 ++-- src/arith/peano.c | 54 ++++++------ src/arith/peano.h | 9 +- src/arith/ratio.c | 145 ++++++++++++++++++--------------- src/arith/ratio.h | 25 ++---- src/io/read.c | 6 +- src/memory/consspaceobject.h | 4 +- src/memory/stack.c | 1 - src/ops/equal.c | 154 ++++++++++++++++++++--------------- src/ops/exceptions.c | 62 -------------- src/ops/lispops.c | 36 ++++++++ 14 files changed, 298 insertions(+), 258 deletions(-) delete mode 100644 src/ops/exceptions.c diff --git a/.gitignore b/.gitignore index 1968658..3bf3906 100644 --- a/.gitignore +++ b/.gitignore @@ -38,3 +38,5 @@ utils_src/readprintwc/out src/io/fopen hi\.* + +.vscode/ diff --git a/lisp/defun.lisp b/lisp/defun.lisp index cec893b..a6d80f5 100644 --- a/lisp/defun.lisp +++ b/lisp/defun.lisp @@ -9,6 +9,11 @@ (set (car form) (apply 'lambda (cdr form)))) (t nil)))) +(set! defun! + (nlambda + form + (eval (list 'set! (car form) (cons 'lambda (cdr form)))))) + (defun! square (x) (* x x)) (set! defsp! diff --git a/src/arith/integer.c b/src/arith/integer.c index 1b2667c..e02d30e 100644 --- a/src/arith/integer.c +++ b/src/arith/integer.c @@ -390,3 +390,38 @@ struct cons_pointer integer_to_string( struct cons_pointer int_pointer, return result; } + +/** + * true if a and be are both integers whose value is the same value. + */ +bool equal_integer_integer(struct cons_pointer a, struct cons_pointer b) { + bool result = false; + + if (integerp(a) && integerp(b)){ + struct cons_space_object *cell_a = &pointer2cell( a ); + struct cons_space_object *cell_b = &pointer2cell( b ); + + result = cell_a->payload.integer.value == cell_b->payload.integer.value; + } + + return result; +} + +/** + * true if `a` is an integer, and `b` is a real number whose value is the + * value of that integer. + */ +bool equal_integer_real(struct cons_pointer a, struct cons_pointer b) { + bool result = false; + + if (integerp(a) && realp(b)) + { + long double bv = pointer2cell(b).payload.real.value; + + if (floor(bv) == bv) { + result = pointer2cell(a).payload.integer.value == (int64_t)bv; + } + } + + return result; +} \ No newline at end of file diff --git a/src/arith/integer.h b/src/arith/integer.h index 117a0bf..f0117f5 100644 --- a/src/arith/integer.h +++ b/src/arith/integer.h @@ -11,15 +11,19 @@ #ifndef __integer_h #define __integer_h -struct cons_pointer make_integer( int64_t value, struct cons_pointer more ); +struct cons_pointer make_integer(int64_t value, struct cons_pointer more); -struct cons_pointer add_integers( struct cons_pointer a, - struct cons_pointer b ); +struct cons_pointer add_integers(struct cons_pointer a, + struct cons_pointer b); -struct cons_pointer multiply_integers( struct cons_pointer a, - struct cons_pointer b ); +struct cons_pointer multiply_integers(struct cons_pointer a, + struct cons_pointer b); -struct cons_pointer integer_to_string( struct cons_pointer int_pointer, - int base ); +struct cons_pointer integer_to_string(struct cons_pointer int_pointer, + int base); + +bool equal_integer_integer(struct cons_pointer a, struct cons_pointer b); + +bool equal_integer_real(struct cons_pointer a, struct cons_pointer b); #endif diff --git a/src/arith/peano.c b/src/arith/peano.c index 8e4cb43..8fe63fb 100644 --- a/src/arith/peano.c +++ b/src/arith/peano.c @@ -86,8 +86,7 @@ bool is_negative( struct cons_pointer arg ) { return result; } -struct cons_pointer absolute( struct cons_pointer frame_pointer, - struct cons_pointer arg ) { +struct cons_pointer absolute( struct cons_pointer arg ) { struct cons_pointer result = NIL; struct cons_space_object cell = pointer2cell( arg ); @@ -99,9 +98,7 @@ struct cons_pointer absolute( struct cons_pointer frame_pointer, cell.payload.integer.more ); break; case RATIOTV: - result = make_ratio( frame_pointer, - absolute( frame_pointer, - cell.payload.ratio.dividend ), + result = make_ratio( absolute( cell.payload.ratio.dividend ), cell.payload.ratio.divisor ); break; case REALTV: @@ -210,7 +207,7 @@ int64_t to_long_int( struct cons_pointer arg ) { struct cons_pointer lisp_absolute( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ) { - return absolute( frame_pointer, frame->arg[0] ); + return absolute( frame->arg[0] ); } /** @@ -251,7 +248,7 @@ struct cons_pointer add_2( struct stack_frame *frame, break; case RATIOTV: result = - add_integer_ratio( frame_pointer, arg1, arg2 ); + add_integer_ratio( arg1, arg2 ); break; case REALTV: result = @@ -272,10 +269,10 @@ struct cons_pointer add_2( struct stack_frame *frame, break; case INTEGERTV: result = - add_integer_ratio( frame_pointer, arg2, arg1 ); + add_integer_ratio( arg2, arg1 ); break; case RATIOTV: - result = add_ratio_ratio( frame_pointer, arg1, arg2 ); + result = add_ratio_ratio( arg1, arg2 ); break; case REALTV: result = @@ -384,7 +381,7 @@ struct cons_pointer multiply_2( struct stack_frame *frame, break; case RATIOTV: result = - multiply_integer_ratio( frame_pointer, arg1, + multiply_integer_ratio( arg1, arg2 ); break; case REALTV: @@ -409,12 +406,12 @@ struct cons_pointer multiply_2( struct stack_frame *frame, break; case INTEGERTV: result = - multiply_integer_ratio( frame_pointer, arg2, + multiply_integer_ratio( arg2, arg1 ); break; case RATIOTV: result = - multiply_ratio_ratio( frame_pointer, arg1, arg2 ); + multiply_ratio_ratio( arg1, arg2 ); break; case REALTV: result = @@ -496,8 +493,7 @@ struct cons_pointer lisp_multiply( struct * return a cons_pointer indicating a number which is the * 0 - the number indicated by `arg`. */ -struct cons_pointer negative( struct cons_pointer frame, - struct cons_pointer arg ) { +struct cons_pointer negative( struct cons_pointer arg ) { struct cons_pointer result = NIL; struct cons_space_object cell = pointer2cell( arg ); @@ -514,9 +510,7 @@ struct cons_pointer negative( struct cons_pointer frame, result = TRUE; break; case RATIOTV: - result = make_ratio( frame, - negative( frame, - cell.payload.ratio.dividend ), + result = make_ratio( negative( cell.payload.ratio.dividend ), cell.payload.ratio.divisor ); break; case REALTV: @@ -571,7 +565,7 @@ struct cons_pointer subtract_2( struct stack_frame *frame, break; case INTEGERTV:{ struct cons_pointer i = - negative( frame_pointer, arg2 ); + negative( arg2 ); inc_ref( i ); result = add_integers( arg1, i ); dec_ref( i ); @@ -579,11 +573,11 @@ struct cons_pointer subtract_2( struct stack_frame *frame, break; case RATIOTV:{ struct cons_pointer tmp = - make_ratio( frame_pointer, arg1, + make_ratio( arg1, make_integer( 1, NIL ) ); inc_ref( tmp ); result = - subtract_ratio_ratio( frame_pointer, tmp, arg2 ); + subtract_ratio_ratio( tmp, arg2 ); dec_ref( tmp ); } break; @@ -606,16 +600,16 @@ struct cons_pointer subtract_2( struct stack_frame *frame, break; case INTEGERTV:{ struct cons_pointer tmp = - make_ratio( frame_pointer, arg2, + make_ratio( arg2, make_integer( 1, NIL ) ); inc_ref( tmp ); result = - subtract_ratio_ratio( frame_pointer, arg1, tmp ); + subtract_ratio_ratio( arg1, tmp ); dec_ref( tmp ); } break; case RATIOTV: - result = subtract_ratio_ratio( frame_pointer, arg1, arg2 ); + result = subtract_ratio_ratio( arg1, arg2 ); break; case REALTV: result = @@ -687,11 +681,11 @@ struct cons_pointer lisp_divide( struct break; case INTEGERTV:{ struct cons_pointer unsimplified = - make_ratio( frame_pointer, frame->arg[0], + make_ratio( frame->arg[0], frame->arg[1] ); /* OK, if result may be unsimplified, we should not inc_ref it * - but if not, we should dec_ref it. */ - result = simplify_ratio( frame_pointer, unsimplified ); + result = simplify_ratio( unsimplified ); if ( !eq( unsimplified, result ) ) { dec_ref( unsimplified ); } @@ -700,10 +694,10 @@ struct cons_pointer lisp_divide( struct case RATIOTV:{ struct cons_pointer one = make_integer( 1, NIL ); struct cons_pointer ratio = - make_ratio( frame_pointer, frame->arg[0], one ); + make_ratio( frame->arg[0], one ); inc_ref( ratio ); result = - divide_ratio_ratio( frame_pointer, ratio, + divide_ratio_ratio( ratio, frame->arg[1] ); dec_ref( ratio ); } @@ -729,10 +723,10 @@ struct cons_pointer lisp_divide( struct struct cons_pointer one = make_integer( 1, NIL ); inc_ref( one ); struct cons_pointer ratio = - make_ratio( frame_pointer, frame->arg[1], one ); + make_ratio( frame->arg[1], one ); inc_ref( ratio ); result = - divide_ratio_ratio( frame_pointer, frame->arg[0], + divide_ratio_ratio( frame->arg[0], ratio ); dec_ref( ratio ); dec_ref( one ); @@ -740,7 +734,7 @@ struct cons_pointer lisp_divide( struct break; case RATIOTV: result = - divide_ratio_ratio( frame_pointer, frame->arg[0], + divide_ratio_ratio( frame->arg[0], frame->arg[1] ); break; case REALTV: diff --git a/src/arith/peano.h b/src/arith/peano.h index 7ad7662..89bfc3d 100644 --- a/src/arith/peano.h +++ b/src/arith/peano.h @@ -19,13 +19,11 @@ bool zerop( struct cons_pointer arg ); -struct cons_pointer negative( struct cons_pointer frame, - struct cons_pointer arg ); +struct cons_pointer negative( struct cons_pointer arg ); bool is_negative( struct cons_pointer arg ); -struct cons_pointer absolute( struct cons_pointer frame_pointer, - struct cons_pointer arg ); +struct cons_pointer absolute( struct cons_pointer arg ); long double to_long_double( struct cons_pointer arg ); @@ -46,8 +44,7 @@ struct cons_pointer lisp_multiply( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ); -struct cons_pointer negative( struct cons_pointer frame, - struct cons_pointer arg ); +struct cons_pointer negative( struct cons_pointer arg ); struct cons_pointer subtract_2( struct stack_frame *frame, struct cons_pointer frame_pointer, diff --git a/src/arith/ratio.c b/src/arith/ratio.c index 65b09da..8976e38 100644 --- a/src/arith/ratio.c +++ b/src/arith/ratio.c @@ -43,52 +43,52 @@ int64_t least_common_multiple( int64_t m, int64_t n ) { return m / greatest_common_divisor( m, n ) * n; } -/** - * return a cons_pointer indicating a number which is of the - * same value as the ratio indicated by `arg`, but which may - * be in a simplified representation. - * @exception If `arg` isn't a ratio, will return an exception. - */ -struct cons_pointer simplify_ratio( struct cons_pointer frame_pointer, - struct cons_pointer arg ) { - struct cons_pointer result = arg; +struct cons_pointer simplify_ratio( struct cons_pointer pointer) { + struct cons_pointer result = pointer; + struct cons_space_object cell = pointer2cell(pointer); + struct cons_space_object dividend = pointer2cell(cell.payload.ratio.dividend); + struct cons_space_object divisor = pointer2cell(cell.payload.ratio.divisor); - if ( ratiop( arg ) ) { - int64_t ddrv = - pointer2cell( pointer2cell( arg ).payload.ratio.dividend ). - payload.integer.value, drrv = - pointer2cell( pointer2cell( arg ).payload.ratio.divisor ). - payload.integer.value, gcd = greatest_common_divisor( ddrv, drrv ); + if (divisor.payload.integer.value == 1) + { + result = pointer2cell(pointer).payload.ratio.dividend; + } + else + { + if (ratiop(pointer)) + { + int64_t ddrv = dividend.payload.integer.value, + drrv = divisor.payload.integer.value, + gcd = greatest_common_divisor(ddrv, drrv); - if ( gcd > 1 ) { - if ( drrv / gcd == 1 ) { - result = make_integer( ddrv / gcd, NIL ); - } else { - result = - make_ratio( frame_pointer, make_integer( ddrv / gcd, NIL ), - make_integer( drrv / gcd, NIL ) ); + if (gcd > 1) + { + if (drrv / gcd == 1) + { + result = make_integer(ddrv / gcd, NIL); + } + else + { + result = + make_ratio(make_integer(ddrv / gcd, NIL), + make_integer(drrv / gcd, NIL)); + } } } - } else { - result = - throw_exception( make_cons( c_string_to_lisp_string - ( L"Shouldn't happen: bad arg to simplify_ratio" ), - arg ), frame_pointer ); } return result; + } - /** * return a cons_pointer indicating a number which is the sum of * the ratios indicated by `arg1` and `arg2`. * @exception will return an exception if either `arg1` or `arg2` is not a * rational number. */ -struct cons_pointer add_ratio_ratio( struct cons_pointer frame_pointer, - struct cons_pointer arg1, +struct cons_pointer add_ratio_ratio( struct cons_pointer arg1, struct cons_pointer arg2 ) { struct cons_pointer r, result; @@ -116,18 +116,17 @@ struct cons_pointer add_ratio_ratio( struct cons_pointer frame_pointer, m1, m2 ); if ( dr1v == dr2v ) { - r = make_ratio( frame_pointer, - make_integer( dd1v + dd2v, NIL ), + r = make_ratio( make_integer( dd1v + dd2v, NIL ), cell1.payload.ratio.divisor ); } else { struct cons_pointer dd1vm = make_integer( dd1v * m1, NIL ), dr1vm = make_integer( dr1v * m1, NIL ), dd2vm = make_integer( dd2v * m2, NIL ), dr2vm = make_integer( dr2v * m2, NIL ), - r1 = make_ratio( frame_pointer, dd1vm, dr1vm ), - r2 = make_ratio( frame_pointer, dd2vm, dr2vm ); + r1 = make_ratio( dd1vm, dr1vm ), + r2 = make_ratio( dd2vm, dr2vm ); - r = add_ratio_ratio( frame_pointer, r1, r2 ); + r = add_ratio_ratio( r1, r2 ); /* because the references on dd1vm, dr1vm, dd2vm and dr2vm were * never incremented except when making r1 and r2, decrementing @@ -136,7 +135,7 @@ struct cons_pointer add_ratio_ratio( struct cons_pointer frame_pointer, dec_ref( r2 ); } - result = simplify_ratio( frame_pointer, r ); + result = simplify_ratio( r ); if ( !eq( r, result ) ) { dec_ref( r ); } @@ -146,7 +145,7 @@ struct cons_pointer add_ratio_ratio( struct cons_pointer frame_pointer, ( L"Shouldn't happen: bad arg to add_ratio_ratio" ), make_cons( arg1, make_cons( arg2, NIL ) ) ), - frame_pointer ); + NIL ); } debug_print( L" => ", DEBUG_ARITH ); @@ -163,16 +162,16 @@ struct cons_pointer add_ratio_ratio( struct cons_pointer frame_pointer, * `ratarg`. * @exception if either `intarg` or `ratarg` is not of the expected type. */ -struct cons_pointer add_integer_ratio( struct cons_pointer frame_pointer, - struct cons_pointer intarg, +struct cons_pointer add_integer_ratio( struct cons_pointer intarg, struct cons_pointer ratarg ) { struct cons_pointer result; if ( integerp( intarg ) && ratiop( ratarg ) ) { + // TODO: not longer works struct cons_pointer one = make_integer( 1, NIL ), - ratio = make_ratio( frame_pointer, intarg, one ); + ratio = make_ratio( intarg, one ); - result = add_ratio_ratio( frame_pointer, ratio, ratarg ); + result = add_ratio_ratio( ratio, ratarg ); dec_ref( one ); dec_ref( ratio ); @@ -183,7 +182,7 @@ struct cons_pointer add_integer_ratio( struct cons_pointer frame_pointer, make_cons( intarg, make_cons( ratarg, NIL ) ) ), - frame_pointer ); + NIL ); } return result; @@ -195,15 +194,14 @@ struct cons_pointer add_integer_ratio( struct cons_pointer frame_pointer, * @exception will return an exception if either `arg1` or `arg2` is not a * rational number. */ -struct cons_pointer divide_ratio_ratio( struct cons_pointer frame_pointer, - struct cons_pointer arg1, +struct cons_pointer divide_ratio_ratio( struct cons_pointer arg1, struct cons_pointer arg2 ) { - struct cons_pointer i = make_ratio( frame_pointer, - pointer2cell( arg2 ).payload. + // TODO: this now has to work if `arg1` is an integer + struct cons_pointer i = make_ratio( pointer2cell( arg2 ).payload. ratio.divisor, pointer2cell( arg2 ).payload. ratio.dividend ), result = - multiply_ratio_ratio( frame_pointer, arg1, i ); + multiply_ratio_ratio( arg1, i ); dec_ref( i ); @@ -216,9 +214,10 @@ struct cons_pointer divide_ratio_ratio( struct cons_pointer frame_pointer, * @exception will return an exception if either `arg1` or `arg2` is not a * rational number. */ -struct cons_pointer multiply_ratio_ratio( struct cons_pointer frame_pointer, struct +struct cons_pointer multiply_ratio_ratio( struct cons_pointer arg1, struct cons_pointer arg2 ) { + // TODO: this now has to work if arg1 is an integer struct cons_pointer result; debug_print( L"multiply_ratio_ratio( arg1 = ", DEBUG_ARITH ); @@ -241,9 +240,9 @@ struct cons_pointer multiply_ratio_ratio( struct cons_pointer frame_pointer, str ddrv = dd1v * dd2v, drrv = dr1v * dr2v; struct cons_pointer unsimplified = - make_ratio( frame_pointer, make_integer( ddrv, NIL ), + make_ratio( make_integer( ddrv, NIL ), make_integer( drrv, NIL ) ); - result = simplify_ratio( frame_pointer, unsimplified ); + result = simplify_ratio( unsimplified ); if ( !eq( unsimplified, result ) ) { dec_ref( unsimplified ); @@ -252,7 +251,7 @@ struct cons_pointer multiply_ratio_ratio( struct cons_pointer frame_pointer, str result = throw_exception( c_string_to_lisp_string ( L"Shouldn't happen: bad arg to multiply_ratio_ratio" ), - frame_pointer ); + NIL ); } return result; @@ -264,15 +263,15 @@ struct cons_pointer multiply_ratio_ratio( struct cons_pointer frame_pointer, str * `ratarg`. * @exception if either `intarg` or `ratarg` is not of the expected type. */ -struct cons_pointer multiply_integer_ratio( struct cons_pointer frame_pointer, - struct cons_pointer intarg, +struct cons_pointer multiply_integer_ratio( struct cons_pointer intarg, struct cons_pointer ratarg ) { struct cons_pointer result; if ( integerp( intarg ) && ratiop( ratarg ) ) { + // TODO: no longer works; fix struct cons_pointer one = make_integer( 1, NIL ), - ratio = make_ratio( frame_pointer, intarg, one ); - result = multiply_ratio_ratio( frame_pointer, ratio, ratarg ); + ratio = make_ratio( intarg, one ); + result = multiply_ratio_ratio( ratio, ratarg ); dec_ref( one ); dec_ref( ratio ); @@ -280,7 +279,7 @@ struct cons_pointer multiply_integer_ratio( struct cons_pointer frame_pointer, result = throw_exception( c_string_to_lisp_string ( L"Shouldn't happen: bad arg to multiply_integer_ratio" ), - frame_pointer ); + NIL ); } return result; @@ -293,11 +292,10 @@ struct cons_pointer multiply_integer_ratio( struct cons_pointer frame_pointer, * @exception will return an exception if either `arg1` or `arg2` is not a * rational number. */ -struct cons_pointer subtract_ratio_ratio( struct cons_pointer frame_pointer, - struct cons_pointer arg1, +struct cons_pointer subtract_ratio_ratio( struct cons_pointer arg1, struct cons_pointer arg2 ) { - struct cons_pointer i = negative( frame_pointer, arg2 ), - result = add_ratio_ratio( frame_pointer, arg1, i ); + struct cons_pointer i = negative( arg2), + result = add_ratio_ratio( arg1, i ); dec_ref( i ); @@ -311,8 +309,7 @@ struct cons_pointer subtract_ratio_ratio( struct cons_pointer frame_pointer, * `frame_pointer`. * @exception if either `dividend` or `divisor` is not an integer. */ -struct cons_pointer make_ratio( struct cons_pointer frame_pointer, - struct cons_pointer dividend, +struct cons_pointer make_ratio( struct cons_pointer dividend, struct cons_pointer divisor ) { struct cons_pointer result; if ( integerp( dividend ) && integerp( divisor ) ) { @@ -326,10 +323,30 @@ struct cons_pointer make_ratio( struct cons_pointer frame_pointer, result = throw_exception( c_string_to_lisp_string ( L"Dividend and divisor of a ratio must be integers" ), - frame_pointer ); + NIL ); } debug_dump_object( result, DEBUG_ARITH ); - return result; } + +/** + * True if a and be are identical ratios, else false. + */ +bool equal_ratio_ratio(struct cons_pointer a, struct cons_pointer b) +{ + bool result = false; + + if (ratiop(a) && ratiop(b)) + { + struct cons_space_object *cell_a = &pointer2cell(a); + struct cons_space_object *cell_b = &pointer2cell(b); + + result = equal_integer_integer(cell_a->payload.ratio.dividend, + cell_b->payload.ratio.dividend) && + equal_integer_integer(cell_a->payload.ratio.divisor, + cell_b->payload.ratio.divisor); + } + + return result; +} \ No newline at end of file diff --git a/src/arith/ratio.h b/src/arith/ratio.h index 5a3b0d6..d440530 100644 --- a/src/arith/ratio.h +++ b/src/arith/ratio.h @@ -11,36 +11,29 @@ #ifndef __ratio_h #define __ratio_h -struct cons_pointer simplify_ratio( struct cons_pointer frame_pointer, - struct cons_pointer arg ); +struct cons_pointer simplify_ratio( struct cons_pointer arg ); -struct cons_pointer add_ratio_ratio( struct cons_pointer frame_pointer, - struct cons_pointer arg1, +struct cons_pointer add_ratio_ratio( struct cons_pointer arg1, struct cons_pointer arg2 ); -struct cons_pointer add_integer_ratio( struct cons_pointer frame_pointer, - struct cons_pointer intarg, +struct cons_pointer add_integer_ratio( struct cons_pointer intarg, struct cons_pointer ratarg ); -struct cons_pointer divide_ratio_ratio( struct cons_pointer frame_pointer, - struct cons_pointer arg1, +struct cons_pointer divide_ratio_ratio( struct cons_pointer arg1, struct cons_pointer arg2 ); -struct cons_pointer multiply_ratio_ratio( struct cons_pointer frame_pointer, struct - cons_pointer arg1, struct +struct cons_pointer multiply_ratio_ratio( struct cons_pointer arg1, struct cons_pointer arg2 ); -struct cons_pointer multiply_integer_ratio( struct cons_pointer frame_pointer, - struct cons_pointer intarg, +struct cons_pointer multiply_integer_ratio( struct cons_pointer intarg, struct cons_pointer ratarg ); -struct cons_pointer subtract_ratio_ratio( struct cons_pointer frame_pointer, - struct cons_pointer arg1, +struct cons_pointer subtract_ratio_ratio( struct cons_pointer arg1, struct cons_pointer arg2 ); -struct cons_pointer make_ratio( struct cons_pointer frame_pointer, - struct cons_pointer dividend, +struct cons_pointer make_ratio( struct cons_pointer dividend, struct cons_pointer divisor ); +bool equal_ratio_ratio(struct cons_pointer a, struct cons_pointer b); #endif diff --git a/src/io/read.c b/src/io/read.c index 4f3ed0a..0f32815 100644 --- a/src/io/read.c +++ b/src/io/read.c @@ -250,7 +250,7 @@ struct cons_pointer read_number( struct stack_frame *frame, if ( seen_period ) { debug_print( L"read_number: converting result to real\n", DEBUG_IO ); - struct cons_pointer div = make_ratio( frame_pointer, result, + struct cons_pointer div = make_ratio( result, make_integer( powl ( to_long_double ( base ), @@ -263,14 +263,14 @@ struct cons_pointer read_number( struct stack_frame *frame, dec_ref( div ); } else if ( integerp( dividend ) ) { debug_print( L"read_number: converting result to ratio\n", DEBUG_IO ); - result = make_ratio( frame_pointer, dividend, result ); + result = make_ratio( dividend, result ); } if ( neg ) { debug_print( L"read_number: converting result to negative\n", DEBUG_IO ); - result = negative( frame_pointer, result ); + result = negative( result ); } debug_print( L"read_number returning\n", DEBUG_IO ); diff --git a/src/memory/consspaceobject.h b/src/memory/consspaceobject.h index 4b0500b..f82b103 100644 --- a/src/memory/consspaceobject.h +++ b/src/memory/consspaceobject.h @@ -346,7 +346,7 @@ * true if `conspoint` points to some sort of a number cell, * else false */ -#define numberp(conspoint) (check_tag(conspoint,INTEGERTAG)||check_tag(conspoint,RATIOTAG)||check_tag(conspoint,REALTAG)||check_tag(conspoint,BIGNUMTAG)) +#define numberp(conspoint) (check_tag(conspoint,INTEGERTAG)||check_tag(conspoint,RATIOTAG)||check_tag(conspoint,REALTAG)) /** * true if `conspoint` points to a sequence (list, string or, later, vector), @@ -614,7 +614,7 @@ struct cons_space_object { */ struct cons_payload cons; /** - * if tag == EXCEPTIONTAG + * if tag == EXCEPTIONTAG || tag == LOOPXTAG */ struct exception_payload exception; /** diff --git a/src/memory/stack.c b/src/memory/stack.c index d6d3c36..e26bd0e 100644 --- a/src/memory/stack.c +++ b/src/memory/stack.c @@ -267,7 +267,6 @@ void dump_frame( URL_FILE * output, struct cons_pointer frame_pointer ) { void dump_stack_trace( URL_FILE * output, struct cons_pointer pointer ) { if ( exceptionp( pointer ) ) { - // todo: if the payload isn't a message, we maybe shouldn't print it? print( output, pointer2cell( pointer ).payload.exception.payload ); url_fputws( L"\n", output ); dump_stack_trace( output, diff --git a/src/ops/equal.c b/src/ops/equal.c index c4d7f54..6a87de8 100644 --- a/src/ops/equal.c +++ b/src/ops/equal.c @@ -12,14 +12,17 @@ #include "conspage.h" #include "consspaceobject.h" +#include "integer.h" #include "peano.h" +#include "ratio.h" /** * Shallow, and thus cheap, equality: true if these two objects are * the same object, else false. */ -bool eq( struct cons_pointer a, struct cons_pointer b ) { - return ( ( a.page == b.page ) && ( a.offset == b.offset ) ); +bool eq(struct cons_pointer a, struct cons_pointer b) +{ + return ((a.page == b.page) && (a.offset == b.offset)); } /** @@ -29,12 +32,12 @@ bool eq( struct cons_pointer a, struct cons_pointer b ) { * @return true if the objects at these two cons pointers have the same tag, * else false. */ -bool same_type( struct cons_pointer a, struct cons_pointer b ) { - struct cons_space_object *cell_a = &pointer2cell( a ); - struct cons_space_object *cell_b = &pointer2cell( b ); +bool same_type(struct cons_pointer a, struct cons_pointer b) +{ + struct cons_space_object *cell_a = &pointer2cell(a); + struct cons_space_object *cell_b = &pointer2cell(b); return cell_a->tag.value == cell_b->tag.value; - } /** @@ -42,82 +45,99 @@ bool same_type( struct cons_pointer a, struct cons_pointer b ) { * @param string the string to test * @return true if it's the end of a string. */ -bool end_of_string( struct cons_pointer string ) { - return nilp( string ) || - pointer2cell( string ).payload.string.character == '\0'; +bool end_of_string(struct cons_pointer string) +{ + return nilp(string) || + pointer2cell(string).payload.string.character == '\0'; } /** * Deep, and thus expensive, equality: true if these two objects have * identical structure, else false. */ -bool equal( struct cons_pointer a, struct cons_pointer b ) { - bool result = eq( a, b ); +bool equal(struct cons_pointer a, struct cons_pointer b) +{ + bool result = eq(a, b); - if ( !result && same_type( a, b ) ) { - struct cons_space_object *cell_a = &pointer2cell( a ); - struct cons_space_object *cell_b = &pointer2cell( b ); + if (!result && same_type(a, b)) + { + struct cons_space_object *cell_a = &pointer2cell(a); + struct cons_space_object *cell_b = &pointer2cell(b); - switch ( cell_a->tag.value ) { - case CONSTV: - case LAMBDATV: - case NLAMBDATV: - result = - equal( cell_a->payload.cons.car, cell_b->payload.cons.car ) - && equal( cell_a->payload.cons.cdr, - cell_b->payload.cons.cdr ); - break; - case KEYTV: - case STRINGTV: - case SYMBOLTV: - /* + switch (cell_a->tag.value) + { + case CONSTV: + case LAMBDATV: + case NLAMBDATV: + result = + equal(cell_a->payload.cons.car, cell_b->payload.cons.car) && equal(cell_a->payload.cons.cdr, + cell_b->payload.cons.cdr); + break; + case KEYTV: + case STRINGTV: + case SYMBOLTV: + /* * slightly complex because a string may or may not have a '\0' * cell at the end, but I'll ignore that for now. I think in * practice only the empty string will. */ - result = - cell_a->payload.string.character == - cell_b->payload.string.character - && ( equal( cell_a->payload.string.cdr, - cell_b->payload.string.cdr ) - || ( end_of_string( cell_a->payload.string.cdr ) - && end_of_string( cell_b->payload.string. - cdr ) ) ); - break; - case INTEGERTV: - result = - ( cell_a->payload.integer.value == - cell_b->payload.integer.value ) && - equal( cell_a->payload.integer.more, - cell_b->payload.integer.more ); - break; - case REALTV: - { - double num_a = to_long_double( a ); - double num_b = to_long_double( b ); - double max = - fabs( num_a ) > - fabs( num_b ) ? fabs( num_a ) : fabs( num_b ); + result = + cell_a->payload.string.character == + cell_b->payload.string.character && + (equal(cell_a->payload.string.cdr, + cell_b->payload.string.cdr) || + (end_of_string(cell_a->payload.string.cdr) && end_of_string(cell_b->payload.string.cdr))); + break; + case INTEGERTV: + result = + (cell_a->payload.integer.value == + cell_b->payload.integer.value) && + equal(cell_a->payload.integer.more, + cell_b->payload.integer.more); + break; + case RATIOTV: + result = equal_ratio_ratio(a, b); + break; + case REALTV: + { + double num_a = to_long_double(a); + double num_b = to_long_double(b); + double max = + fabs(num_a) > + fabs(num_b) + ? fabs(num_a) + : fabs(num_b); - /* - * not more different than one part in a million - close enough - */ - result = fabs( num_a - num_b ) < ( max / 1000000.0 ); - } - break; - default: - result = false; - break; + /* + * not more different than one part in a million - close enough + */ + result = fabs(num_a - num_b) < (max / 1000000.0); + } + break; + default: + result = false; + break; } - - /* - * there's only supposed ever to be one T and one NIL cell, so each - * should be caught by eq; equality of vector-space objects is a whole - * other ball game so we won't deal with it now (and indeed may never). - * I'm not certain what equality means for read and write streams, so - * I'll ignore them, too, for now. - */ } + else if (numberp(a) && numberp(b)) + { + if (integerp(a)) + { + result = equal_integer_real(a, b); + } + else if (integerp(b)) + { + result = equal_integer_real(b, a); + } + } + + /* + * there's only supposed ever to be one T and one NIL cell, so each + * should be caught by eq; equality of vector-space objects is a whole + * other ball game so we won't deal with it now (and indeed may never). + * I'm not certain what equality means for read and write streams, so + * I'll ignore them, too, for now. + */ return result; } diff --git a/src/ops/exceptions.c b/src/ops/exceptions.c deleted file mode 100644 index 48c031f..0000000 --- a/src/ops/exceptions.c +++ /dev/null @@ -1,62 +0,0 @@ - /* - * exceptions.c - * - * This is really, really unfinished and doesn't yet work. One of the really key - * things about exceptions is that the stack frames between the throw and the - * catch should not be derefed, so eval/apply will need to be substantially - * re-written. - * - * (c) 2021 Simon Brooke - * Licensed under GPL version 2.0, or, at your option, any later version. - */ - -#include -#include -#include -#include -#include - -#include "consspaceobject.h" -#include "conspage.h" -#include "debug.h" -#include "dump.h" -#include "equal.h" -#include "integer.h" -#include "intern.h" -#include "io.h" -#include "lispops.h" -#include "map.h" -#include "print.h" -#include "read.h" -#include "stack.h" -#include "vectorspace.h" - - -/** - * OK, the idea here (and I know this is less than perfect) is that the basic `try` - * function in PSSE takes two arguments, the first, `body`, being a list of forms, - * and the second, `catch`, being a catch handler (which is also a list of forms). - * Forms from `body` are evaluated in turn until one returns an exception object, - * or until the list is exhausted. If the list was exhausted, then the value of - * evaluating the last form in `body` is returned. If an exception was encountered, - * then each of the forms in `catch` is evaluated and the value of the last of - * those is returned. - * - * This is experimental. It almost certainly WILL change. - */ -struct cons_pointer lisp_try(struct stack_frame *frame, - struct cons_pointer frame_pointer, - struct cons_pointer env) -{ - struct cons_pointer result = c_progn(frame, frame_pointer, frame->arg[0], env); - - if (loopexitp(result)) - { - // TODO: need to put the exception into the environment! - result = c_progn(frame, frame_pointer, frame->arg[1], env); - } - - return result; -} - - diff --git a/src/ops/lispops.c b/src/ops/lispops.c index 8dd0109..c96b1be 100644 --- a/src/ops/lispops.c +++ b/src/ops/lispops.c @@ -110,6 +110,37 @@ struct cons_pointer eval_forms( struct stack_frame *frame, return c_reverse( result); } +/** + * OK, the idea here (and I know this is less than perfect) is that the basic `try` + * function in PSSE takes two arguments, the first, `body`, being a list of forms, + * and the second, `catch`, being a catch handler (which is also a list of forms). + * Forms from `body` are evaluated in turn until one returns an exception object, + * or until the list is exhausted. If the list was exhausted, then the value of + * evaluating the last form in `body` is returned. If an exception was encountered, + * then each of the forms in `catch` is evaluated and the value of the last of + * those is returned. + * + * This is experimental. It almost certainly WILL change. + */ +struct cons_pointer lisp_try(struct stack_frame *frame, + struct cons_pointer frame_pointer, + struct cons_pointer env) { + struct cons_pointer result = c_progn(frame, frame_pointer, frame->arg[0], env); + + if (exceptionp(result)) + { + // TODO: need to put the exception into the environment! + result = c_progn(frame, frame_pointer, frame->arg[1], + make_cons( + make_cons(c_string_to_lisp_keyword(L"*exception*"), + result), + env)); + } + + return result; +} + + /** * Return the object list (root namespace). * @@ -251,6 +282,11 @@ eval_lambda( struct cons_space_object cell, struct stack_frame *frame, dec_ref( result ); result = eval_form( frame, frame_pointer, sexpr, new_env ); + + if (exceptionp(result)) + { + break; + } } dec_ref( new_env ); From 3f3b596ff0f2e2b35b1328110836717994cb531c Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Tue, 3 Aug 2021 15:46:50 +0100 Subject: [PATCH 04/28] Added the beginnings of hashmap but does not yet compile. --- .vscode/settings.json | 7 ----- src/memory/conspage.h | 2 +- src/memory/consspaceobject.c | 42 ++++++++++++++++++++++--- src/memory/consspaceobject.h | 7 +++-- src/memory/hashmap.c | 61 ++++++++++++++++++++++++++++++++++++ src/memory/hashmap.h | 36 +++++++++++++++++++++ src/ops/equal.c | 25 +++++++++------ 7 files changed, 154 insertions(+), 26 deletions(-) delete mode 100644 .vscode/settings.json create mode 100644 src/memory/hashmap.c create mode 100644 src/memory/hashmap.h diff --git a/.vscode/settings.json b/.vscode/settings.json deleted file mode 100644 index 14fb483..0000000 --- a/.vscode/settings.json +++ /dev/null @@ -1,7 +0,0 @@ -{ - "files.associations": { - "future": "cpp", - "system_error": "cpp", - "functional": "c" - } -} \ No newline at end of file diff --git a/src/memory/conspage.h b/src/memory/conspage.h index f13a46b..9eab748 100644 --- a/src/memory/conspage.h +++ b/src/memory/conspage.h @@ -13,7 +13,7 @@ #ifndef __psse_conspage_h #define __psse_conspage_h -#include "consspaceobject.h" +#include "memory/consspaceobject.h" /** * the number of cons cells on a cons page. The maximum value this can diff --git a/src/memory/consspaceobject.c b/src/memory/consspaceobject.c index 98bb495..080158d 100644 --- a/src/memory/consspaceobject.c +++ b/src/memory/consspaceobject.c @@ -101,16 +101,16 @@ struct cons_pointer c_car( struct cons_pointer arg ) { struct cons_pointer c_cdr( struct cons_pointer arg ) { struct cons_pointer result = NIL; - struct cons_space_object cell = pointer2cell( arg ); + struct cons_space_object *cell = &pointer2cell( arg ); - switch (cell.tag.value) { + switch (cell->tag.value) { case CONSTV: - result = pointer2cell( arg ).payload.cons.cdr; + result = cell->payload.cons.cdr; break; case KEYTV: case STRINGTV: case SYMBOLTV: - result = pointer2cell( arg ).payload.string.cdr; + result = cell->payload.string.cdr; break; } @@ -226,6 +226,36 @@ struct cons_pointer make_nlambda( struct cons_pointer args, return pointer; } +/** + * Return a hash value for this string. + * + * What's important here is that two strings with the same characters in the + * same order should have the same hash value, even if one was created using + * `"foobar"` and the other by `(append "foo" "bar")`. I *think* this function + * has that property. I doubt that it's the most efficient hash function to + * have that property. + */ +uint32_t calculate_hash( wint_t c, struct cons_pointer ptr) { +struct cons_space_object *cell = &pointer2cell(ptr); + uint32_t result = 0; + + switch (cell->tag.value) + { + case KEYTV: + case STRINGTV: + case SYMBOLTV: + if (nilp(ptr)) { + result =(uint32_t) c; + } else { + result = ((uint32_t)c * + cell->payload.string.hash) & + 0xffffffff; + } + } + + return result; +} + /** * Construct a string from this character (which later will be UTF) and * this tail. A string is implemented as a flat list of cells each of which @@ -245,8 +275,10 @@ make_string_like_thing( wint_t c, struct cons_pointer tail, char *tag ) { cell->payload.string.cdr.page = tail.page; /* \todo There's a problem here. Sometimes the offsets on * strings are quite massively off. Fix is probably - * cell->payload.string.cdr = tsil */ + * cell->payload.string.cdr = tail */ cell->payload.string.cdr.offset = tail.offset; + + cell->payload.string.hash = calculate_hash(c, tail); } else { // \todo should throw an exception! debug_printf( DEBUG_ALLOC, diff --git a/src/memory/consspaceobject.h b/src/memory/consspaceobject.h index f82b103..7bf34de 100644 --- a/src/memory/consspaceobject.h +++ b/src/memory/consspaceobject.h @@ -20,7 +20,8 @@ #include #include -#include "fopen.h" +#include "io/fopen.h" +#include "memory/conspage.h" /** @@ -557,8 +558,8 @@ struct stream_payload { struct string_payload { /** the actual character stored in this cell */ wint_t character; - /** unused padding to word-align the cdr */ - uint32_t padding; + /** a hash of the string value, computed at store time. */ + uint32_t hash; /** the remainder of the string following this character. */ struct cons_pointer cdr; }; diff --git a/src/memory/hashmap.c b/src/memory/hashmap.c new file mode 100644 index 0000000..fcd69e4 --- /dev/null +++ b/src/memory/hashmap.c @@ -0,0 +1,61 @@ +/* + * hashmap.c + * + * Basic implementation of a hashmap. + * + * (c) 2021 Simon Brooke + * Licensed under GPL version 2.0, or, at your option, any later version. + */ + +#include "arith/integer.h" +#include "memory/consspaceobject.h" +#include "memory/hashmap.h" + +/** + * Get the hash value for the cell indicated by this `ptr`; currently only + * implemented for string like things. + */ +uint32_t get_hash(struct cons_pointer ptr) +{ + struct cons_space_object *cell = &pointer2cell(ptr); + uint32_t result = 0; + + switch (cell->tag.value) + { + case KEYTV: + case STRINGTV: + case SYMBOLTV: + result = cell->payload.string.hash; + default: + // TODO: Not Yet Implemented + result = 0; + } + + return result; +} + +/** + * A lisp function signature conforming wrapper around get_hash, q.v.. + */ +struct cons_pointer lisp_get_hash(struct stack_frame *frame, + struct cons_pointer frame_pointer, + struct cons_pointer env) +{ + return make_integer(get_hash(frame->arg[0]), NIL); +} + +/** + * Make a hashmap with this number of buckets. + */ +struct cons_pointer make_hashmap( uint32_t n_buckets) { + struct cons_pointer result = make_vso(HASHTAG, + (sizeof(struct cons_pointer) * (n_buckets + 1)) + + (sizeof(uint32_t) * 2)); + + // TODO: fill in the payload! + + struct hashmap_payload *payload = + (struct hashmap_payload *) &pointer_to_vso(result)->payload; + + return result; +} \ No newline at end of file diff --git a/src/memory/hashmap.h b/src/memory/hashmap.h new file mode 100644 index 0000000..b834f5a --- /dev/null +++ b/src/memory/hashmap.h @@ -0,0 +1,36 @@ +/* + * hashmap.h + * + * Basic implementation of a hashmap. + * + * (c) 2021 Simon Brooke + * Licensed under GPL version 2.0, or, at your option, any later version. + */ + +#ifndef __psse_hashmap_h +#define __psse_hashmap_h + +#include "memory/consspaceobject.h" +#include "memory/vectorspace.h" + +/** + * The payload of a hashmap. The number of buckets is assigned at run-time, + * and is stored in n_buckets. Each bucket is something ASSOC can consume: + * i.e. either an assoc list or a further hashmap. + */ +struct hashmap_payload { + struct cons_pointer hash_fn; + uint32_t n_buckets; + uint32_t unused; /* for word alignment and possible later expansion */ + struct cons_pointer buckets[]; +}; + +uint32_t get_hash(struct cons_pointer ptr); + +struct cons_pointer lisp_get_hash(struct stack_frame *frame, + struct cons_pointer frame_pointer, + struct cons_pointer env); + +struct cons_pointer make_hashmap( uint32_t n_buckets, struct cons_pointer hash_fn); + +#endif \ No newline at end of file diff --git a/src/ops/equal.c b/src/ops/equal.c index 6a87de8..feffb93 100644 --- a/src/ops/equal.c +++ b/src/ops/equal.c @@ -10,11 +10,11 @@ #include #include -#include "conspage.h" -#include "consspaceobject.h" -#include "integer.h" -#include "peano.h" -#include "ratio.h" +#include "memory/conspage.h" +#include "memory/consspaceobject.h" +#include "arith/integer.h" +#include "arith/peano.h" +#include "arith/ratio.h" /** * Shallow, and thus cheap, equality: true if these two objects are @@ -69,6 +69,9 @@ bool equal(struct cons_pointer a, struct cons_pointer b) case CONSTV: case LAMBDATV: case NLAMBDATV: + /* TODO: it is not OK to do this on the stack since list-like + * structures can be of indefinite extent. It *must* be done by + * iteration (and even that is problematic) */ result = equal(cell_a->payload.cons.car, cell_b->payload.cons.car) && equal(cell_a->payload.cons.cdr, cell_b->payload.cons.cdr); @@ -76,11 +79,13 @@ bool equal(struct cons_pointer a, struct cons_pointer b) case KEYTV: case STRINGTV: case SYMBOLTV: - /* - * slightly complex because a string may or may not have a '\0' - * cell at the end, but I'll ignore that for now. I think in - * practice only the empty string will. - */ + /* slightly complex because a string may or may not have a '\0' + * cell at the end, but I'll ignore that for now. I think in + * practice only the empty string will. + */ + /* TODO: it is not OK to do this on the stack since list-like + * structures can be of indefinite extent. It *must* be done by + * iteration (and even that is problematic) */ result = cell_a->payload.string.character == cell_b->payload.string.character && From 492460f37e61b5c86269daa40b25d6f439ef264e Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Wed, 4 Aug 2021 11:16:00 +0100 Subject: [PATCH 05/28] Compiles and tests, but there are still major problems. --- src/arith/integer.h | 3 ++ src/memory/consspaceobject.c | 67 ++++++++++++++++++++++++++---------- src/memory/consspaceobject.h | 2 +- src/memory/hashmap.c | 24 ++++++++++--- src/memory/hashmap.h | 2 ++ src/memory/vectorspace.h | 6 ++++ 6 files changed, 81 insertions(+), 23 deletions(-) diff --git a/src/arith/integer.h b/src/arith/integer.h index f0117f5..4ce58d5 100644 --- a/src/arith/integer.h +++ b/src/arith/integer.h @@ -11,6 +11,9 @@ #ifndef __integer_h #define __integer_h +#include +#include + struct cons_pointer make_integer(int64_t value, struct cons_pointer more); struct cons_pointer add_integers(struct cons_pointer a, diff --git a/src/memory/consspaceobject.c b/src/memory/consspaceobject.c index 080158d..c240c4d 100644 --- a/src/memory/consspaceobject.c +++ b/src/memory/consspaceobject.c @@ -24,13 +24,30 @@ #include "intern.h" #include "print.h" #include "stack.h" +#include "vectorspace.h" /** - * True if the tag on the cell at this `pointer` is this `tag`, else false. + * True if the tag on the cell at this `pointer` is this `tag`, or, if the tag + * of the cell is `VECP`, if the tag of the vectorspace object indicated by the + * cell is this `tag`, else false. */ bool check_tag( struct cons_pointer pointer, char *tag ) { - struct cons_space_object cell = pointer2cell( pointer ); - return strncmp( &cell.tag.bytes[0], tag, TAGLENGTH ) == 0; + bool result = false; + struct cons_space_object cell = pointer2cell( pointer ); + + result = strncmp( &cell.tag.bytes[0], tag, TAGLENGTH ) == 0; + + if ( !result ) { + // if ( vectorpointp( pointer ) ) { <<< this line blows up! + // // struct vector_space_object *vec = pointer_to_vso( pointer ); + + // // if ( vec != NULL ) { + // // result = strncmp( &vec->header.tag.bytes[0], tag, TAGLENGTH ) == 0; + // // } + // } + } + + return result; } /** @@ -72,14 +89,22 @@ void dec_ref( struct cons_pointer pointer ) { * @return As a Lisp string, the tag of the object which is at that pointer. */ struct cons_pointer c_type( struct cons_pointer pointer ) { - struct cons_pointer result = NIL; - struct cons_space_object cell = pointer2cell( pointer ); + struct cons_pointer result = NIL; + struct cons_space_object cell = pointer2cell( pointer ); + + if ( strncmp( (char *)&cell.tag.bytes, VECTORPOINTTAG, TAGLENGTH ) == 0 ) { + struct vector_space_object *vec = pointer_to_vso( pointer ); for ( int i = TAGLENGTH - 1; i >= 0; i-- ) { - result = make_string( ( wchar_t ) cell.tag.bytes[i], result ); + result = make_string( (wchar_t)vec->header.tag.bytes[i], result ); } + } else { + for ( int i = TAGLENGTH - 1; i >= 0; i-- ) { + result = make_string( (wchar_t)cell.tag.bytes[i], result ); + } + } - return result; + return result; } /** @@ -227,16 +252,19 @@ struct cons_pointer make_nlambda( struct cons_pointer args, } /** - * Return a hash value for this string. + * Return a hash value for this string like thing. * * What's important here is that two strings with the same characters in the * same order should have the same hash value, even if one was created using * `"foobar"` and the other by `(append "foo" "bar")`. I *think* this function * has that property. I doubt that it's the most efficient hash function to * have that property. - */ -uint32_t calculate_hash( wint_t c, struct cons_pointer ptr) { -struct cons_space_object *cell = &pointer2cell(ptr); + * + * returns 0 for things which are not string like. + */ +uint32_t calculate_hash(wint_t c, struct cons_pointer ptr) +{ + struct cons_space_object *cell = &pointer2cell(ptr); uint32_t result = 0; switch (cell->tag.value) @@ -244,13 +272,16 @@ struct cons_space_object *cell = &pointer2cell(ptr); case KEYTV: case STRINGTV: case SYMBOLTV: - if (nilp(ptr)) { - result =(uint32_t) c; - } else { - result = ((uint32_t)c * - cell->payload.string.hash) & - 0xffffffff; - } + if (nilp(ptr)) + { + result = (uint32_t)c; + } + else + { + result = ((uint32_t)c * + cell->payload.string.hash) & + 0xffffffff; + } } return result; diff --git a/src/memory/consspaceobject.h b/src/memory/consspaceobject.h index 7bf34de..486efe2 100644 --- a/src/memory/consspaceobject.h +++ b/src/memory/consspaceobject.h @@ -21,7 +21,7 @@ #include #include "io/fopen.h" -#include "memory/conspage.h" +// #include "memory/conspage.h" /** diff --git a/src/memory/hashmap.c b/src/memory/hashmap.c index fcd69e4..edabb89 100644 --- a/src/memory/hashmap.c +++ b/src/memory/hashmap.c @@ -10,6 +10,7 @@ #include "arith/integer.h" #include "memory/consspaceobject.h" #include "memory/hashmap.h" +#include "memory/vectorspace.h" /** * Get the hash value for the cell indicated by this `ptr`; currently only @@ -45,17 +46,32 @@ struct cons_pointer lisp_get_hash(struct stack_frame *frame, } /** - * Make a hashmap with this number of buckets. + * Make a hashmap with this number of buckets, using this `hash_fn`. If + * `hash_fn` is `NIL`, use the standard hash funtion. */ -struct cons_pointer make_hashmap( uint32_t n_buckets) { +struct cons_pointer make_hashmap( uint32_t n_buckets, struct cons_pointer hash_fn) { struct cons_pointer result = make_vso(HASHTAG, (sizeof(struct cons_pointer) * (n_buckets + 1)) + (sizeof(uint32_t) * 2)); - // TODO: fill in the payload! - struct hashmap_payload *payload = (struct hashmap_payload *) &pointer_to_vso(result)->payload; + payload->hash_fn = hash_fn; + payload->n_buckets = n_buckets; + for (int i = 0; i < n_buckets; i++) { + payload->buckets[i] = NIL; + } + + return result; +} + +struct cons_pointer clone_hashmap(struct cons_pointer ptr) { + struct cons_pointer result = NIL; + + if (hashmapp(ptr)) { + + } + return result; } \ No newline at end of file diff --git a/src/memory/hashmap.h b/src/memory/hashmap.h index b834f5a..813211b 100644 --- a/src/memory/hashmap.h +++ b/src/memory/hashmap.h @@ -10,6 +10,8 @@ #ifndef __psse_hashmap_h #define __psse_hashmap_h +#include "arith/integer.h" +#include "memory/conspage.h" #include "memory/consspaceobject.h" #include "memory/vectorspace.h" diff --git a/src/memory/vectorspace.h b/src/memory/vectorspace.h index 22b0d88..15740ac 100644 --- a/src/memory/vectorspace.h +++ b/src/memory/vectorspace.h @@ -28,18 +28,24 @@ #define HASHTAG "HASH" #define HASHTV 0 +#define hashmapp(conspoint)((check_tag(conspoint,HASHTAG))) + /* * a namespace (i.e. a binding of names to values, implemented as a hashmap) */ #define NAMESPACETAG "NMSP" #define NAMESPACETV 0 +#define namespacep(conspoint)(check_tag(conspoint,NAMESPACETAG)) + /* * a vector of cons pointers. */ #define VECTORTAG "VECT" #define VECTORTV 0 +#define vectorp(conspoint)(check_tag(conspoint,VECTORTAG)) + /** * given a pointer to a vector space object, return the object. */ From 6f54b92d3205146a036ae695f7785108f61b9b15 Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Thu, 5 Aug 2021 23:35:21 +0100 Subject: [PATCH 06/28] check_tag now works for vectorspace as well as consspace tags All tests except bignum boundary tests still pass. --- src/memory/consspaceobject.c | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) diff --git a/src/memory/consspaceobject.c b/src/memory/consspaceobject.c index c240c4d..06bf41c 100644 --- a/src/memory/consspaceobject.c +++ b/src/memory/consspaceobject.c @@ -37,14 +37,14 @@ bool check_tag( struct cons_pointer pointer, char *tag ) { result = strncmp( &cell.tag.bytes[0], tag, TAGLENGTH ) == 0; - if ( !result ) { - // if ( vectorpointp( pointer ) ) { <<< this line blows up! - // // struct vector_space_object *vec = pointer_to_vso( pointer ); + if ( result == false ) { + if ( strncmp( &cell.tag.bytes, VECTORPOINTTAG, TAGLENGTH ) == 0 ) { + struct vector_space_object *vec = pointer_to_vso( pointer ); - // // if ( vec != NULL ) { - // // result = strncmp( &vec->header.tag.bytes[0], tag, TAGLENGTH ) == 0; - // // } - // } + if ( vec != NULL ) { + result = strncmp( &vec->header.tag.bytes[0], tag, TAGLENGTH ) == 0; + } + } } return result; From 132f5fb268547056603d40da8c20d73aefe37fc4 Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Fri, 6 Aug 2021 00:24:19 +0100 Subject: [PATCH 07/28] More work on hashmaps --- src/memory/hashmap.c | 56 +++++++++++++++++++++++++++++--------------- 1 file changed, 37 insertions(+), 19 deletions(-) diff --git a/src/memory/hashmap.c b/src/memory/hashmap.c index edabb89..b8110e4 100644 --- a/src/memory/hashmap.c +++ b/src/memory/hashmap.c @@ -49,29 +49,47 @@ struct cons_pointer lisp_get_hash(struct stack_frame *frame, * Make a hashmap with this number of buckets, using this `hash_fn`. If * `hash_fn` is `NIL`, use the standard hash funtion. */ -struct cons_pointer make_hashmap( uint32_t n_buckets, struct cons_pointer hash_fn) { - struct cons_pointer result = make_vso(HASHTAG, - (sizeof(struct cons_pointer) * (n_buckets + 1)) + - (sizeof(uint32_t) * 2)); +struct cons_pointer make_hashmap( uint32_t n_buckets, + struct cons_pointer hash_fn ) { + struct cons_pointer result = + make_vso( HASHTAG, ( sizeof( struct cons_pointer ) * ( n_buckets + 1 ) ) + + ( sizeof( uint32_t ) * 2 ) ); - struct hashmap_payload *payload = - (struct hashmap_payload *) &pointer_to_vso(result)->payload; + struct hashmap_payload *payload = + (struct hashmap_payload *)&pointer_to_vso( result )->payload; - payload->hash_fn = hash_fn; - payload->n_buckets = n_buckets; - for (int i = 0; i < n_buckets; i++) { - payload->buckets[i] = NIL; + payload->hash_fn = hash_fn; + payload->n_buckets = n_buckets; + for ( int i = 0; i < n_buckets; i++ ) { + payload->buckets[i] = NIL; + } + + return result; +} + +/** + * If this `ptr` is a pointer to a hashmap, return a new identical hashmap; + * else return `NIL`. TODO: should return an exception. + */ +struct cons_pointer clone_hashmap(struct cons_pointer ptr) { + struct cons_pointer result = NIL; + + if (hashmapp(ptr)) { + struct vector_space_object *from = pointer_to_vso( ptr ); + + if ( from != NULL ) { + struct hashmap_payload *from_pl = (struct hashmap_payload*)from->payload; + result = make_hashmap( from_pl->n_buckets, from_pl->hash_fn); + struct vector_space_object *to = pointer_to_vso(result); + struct hashmap_payload *to_pl = (struct hashmap_payload*)to->payload; + + for (int i = 0; i < to_pl->n_buckets; i++) { + to_pl->buckets[i] = from_pl->buckets[i]; + inc_ref(to_pl->buckets[i]); + } + } } return result; } -struct cons_pointer clone_hashmap(struct cons_pointer ptr) { - struct cons_pointer result = NIL; - - if (hashmapp(ptr)) { - - } - - return result; -} \ No newline at end of file From bfd7304da129dd6ce69a3885800595ff67ae6899 Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Mon, 16 Aug 2021 15:12:05 +0100 Subject: [PATCH 08/28] Bother. It looks like I'd already fully implemented hashmaps... May need to back out a whole hill of work. --- src/arith/peano.h | 2 + src/authorise.c | 24 ++++ src/authorise.h | 15 +++ src/memory/conspage.c | 20 +-- src/memory/consspaceobject.c | 48 ++++--- src/memory/consspaceobject.h | 4 +- src/memory/hashmap.c | 255 +++++++++++++++++++++++++++++++---- src/memory/hashmap.h | 32 ++--- src/memory/vectorspace.c | 26 ++++ src/memory/vectorspace.h | 30 ++++- src/ops/intern.c | 5 +- 11 files changed, 378 insertions(+), 83 deletions(-) create mode 100644 src/authorise.c create mode 100644 src/authorise.h diff --git a/src/arith/peano.h b/src/arith/peano.h index 89bfc3d..9bcd9e4 100644 --- a/src/arith/peano.h +++ b/src/arith/peano.h @@ -27,6 +27,8 @@ struct cons_pointer absolute( struct cons_pointer arg ); long double to_long_double( struct cons_pointer arg ); +int64_t to_long_int( struct cons_pointer arg ) ; + struct cons_pointer lisp_absolute( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ); diff --git a/src/authorise.c b/src/authorise.c new file mode 100644 index 0000000..5574db9 --- /dev/null +++ b/src/authorise.c @@ -0,0 +1,24 @@ +/* + * authorised.c + * + * For now, a dummy authorising everything. + * + * (c) 2021 Simon Brooke + * Licensed under GPL version 2.0, or, at your option, any later version. + */ + +#include "memory/conspage.h" +#include "memory/consspaceobject.h" + + +/** + * TODO: does nothing, yet. What it should do is access a magic value in the + * runtime environment and check that it is identical to something on this `acl` + */ +struct cons_pointer authorised(struct cons_pointer target, struct cons_pointer acl) { + if (nilp(acl)) { + acl = pointer2cell(target).access; + } + return TRUE; +} + diff --git a/src/authorise.h b/src/authorise.h new file mode 100644 index 0000000..c67977d --- /dev/null +++ b/src/authorise.h @@ -0,0 +1,15 @@ +/* + * authorise.h + * + * Basic implementation of a authorisation. + * + * (c) 2021 Simon Brooke + * Licensed under GPL version 2.0, or, at your option, any later version. + */ + +#ifndef __psse_authorise_h +#define __psse_authorise_h + +struct cons_pointer authorised(struct cons_pointer target, struct cons_pointer acl); + +#endif \ No newline at end of file diff --git a/src/memory/conspage.c b/src/memory/conspage.c index 53496d3..c9c224d 100644 --- a/src/memory/conspage.c +++ b/src/memory/conspage.c @@ -179,26 +179,8 @@ void free_cell( struct cons_pointer pointer ) { dec_ref( cell->payload.string.cdr ); break; case VECTORPOINTTV: - /* for vector space pointers, free the actual vector-space - * object. Dangerous! */ - debug_printf( DEBUG_ALLOC, - L"About to free vector-space object at 0x%lx\n", - cell->payload.vectorp.address ); - struct vector_space_object *vso = - cell->payload.vectorp.address; - - switch ( vso->header.tag.value ) { - case STACKFRAMETV: - free_stack_frame( get_stack_frame( pointer ) ); - break; - } - - free( ( void * ) cell->payload.vectorp.address ); - debug_printf( DEBUG_ALLOC, - L"Freed vector-space object at 0x%lx\n", - cell->payload.vectorp.address ); + free_vso( pointer); break; - } strncpy( &cell->tag.bytes[0], FREETAG, TAGLENGTH ); diff --git a/src/memory/consspaceobject.c b/src/memory/consspaceobject.c index 06bf41c..ee82956 100644 --- a/src/memory/consspaceobject.c +++ b/src/memory/consspaceobject.c @@ -18,6 +18,7 @@ #include #include +#include "authorise.h" #include "conspage.h" #include "consspaceobject.h" #include "debug.h" @@ -38,7 +39,7 @@ bool check_tag( struct cons_pointer pointer, char *tag ) { result = strncmp( &cell.tag.bytes[0], tag, TAGLENGTH ) == 0; if ( result == false ) { - if ( strncmp( &cell.tag.bytes, VECTORPOINTTAG, TAGLENGTH ) == 0 ) { + if ( strncmp( &cell.tag.bytes[0], VECTORPOINTTAG, TAGLENGTH ) == 0 ) { struct vector_space_object *vec = pointer_to_vso( pointer ); if ( vec != NULL ) { @@ -55,13 +56,17 @@ bool check_tag( struct cons_pointer pointer, char *tag ) { * * You can't roll over the reference count. Once it hits the maximum * value you cannot increment further. + * + * Returns the `pointer`. */ -void inc_ref( struct cons_pointer pointer ) { +struct cons_pointer inc_ref( struct cons_pointer pointer ) { struct cons_space_object *cell = &pointer2cell( pointer ); if ( cell->count < MAXREFERENCE ) { cell->count++; } + + return pointer; } /** @@ -69,8 +74,10 @@ void inc_ref( struct cons_pointer pointer ) { * * If a count has reached MAXREFERENCE it cannot be decremented. * If a count is decremented to zero the cell should be freed. + * + * Returns the `pointer`, or, if the cell has been freed, NIL. */ -void dec_ref( struct cons_pointer pointer ) { +struct cons_pointer dec_ref( struct cons_pointer pointer ) { struct cons_space_object *cell = &pointer2cell( pointer ); if ( cell->count > 0 ) { @@ -78,8 +85,11 @@ void dec_ref( struct cons_pointer pointer ) { if ( cell->count == 0 ) { free_cell( pointer ); + pointer = NIL; } } + + return pointer; } @@ -108,38 +118,42 @@ struct cons_pointer c_type( struct cons_pointer pointer ) { } /** - * Implementation of car in C. If arg is not a cons, does not error but returns nil. + * Implementation of car in C. If arg is not a cons, or the current user is not + * authorised to read it, does not error but returns nil. */ struct cons_pointer c_car( struct cons_pointer arg ) { - struct cons_pointer result = NIL; + struct cons_pointer result = NIL; - if ( consp( arg ) ) { - result = pointer2cell( arg ).payload.cons.car; - } + if ( truep( authorised( arg, NIL ) ) && consp( arg ) ) { + result = pointer2cell( arg ).payload.cons.car; + } - return result; + return result; } /** - * Implementation of cdr in C. If arg is not a sequence, does not error but returns nil. + * Implementation of cdr in C. If arg is not a sequence, or the current user is + * not authorised to read it,does not error but returns nil. */ struct cons_pointer c_cdr( struct cons_pointer arg ) { - struct cons_pointer result = NIL; + struct cons_pointer result = NIL; + if ( truep( authorised( arg, NIL ) ) ) { struct cons_space_object *cell = &pointer2cell( arg ); - switch (cell->tag.value) { - case CONSTV: + switch ( cell->tag.value ) { + case CONSTV: result = cell->payload.cons.cdr; break; - case KEYTV: - case STRINGTV: - case SYMBOLTV: + case KEYTV: + case STRINGTV: + case SYMBOLTV: result = cell->payload.string.cdr; break; } + } - return result; + return result; } /** diff --git a/src/memory/consspaceobject.h b/src/memory/consspaceobject.h index 486efe2..98a5a24 100644 --- a/src/memory/consspaceobject.h +++ b/src/memory/consspaceobject.h @@ -675,9 +675,9 @@ struct cons_space_object { bool check_tag( struct cons_pointer pointer, char *tag ); -void inc_ref( struct cons_pointer pointer ); +struct cons_pointer inc_ref( struct cons_pointer pointer ); -void dec_ref( struct cons_pointer pointer ); +struct cons_pointer dec_ref( struct cons_pointer pointer ); struct cons_pointer c_type( struct cons_pointer pointer ); diff --git a/src/memory/hashmap.c b/src/memory/hashmap.c index b8110e4..9be7d64 100644 --- a/src/memory/hashmap.c +++ b/src/memory/hashmap.c @@ -8,33 +8,89 @@ */ #include "arith/integer.h" +#include "arith/peano.h" +#include "authorise.h" +#include "debug.h" #include "memory/consspaceobject.h" #include "memory/hashmap.h" #include "memory/vectorspace.h" +/** + * Return a hash value for the structure indicated by `ptr` such that if + * `x`,`y` are two separate structures whose print representation is the same + * then `(sxhash x)` and `(sxhash y)` will always be equal. + */ +uint32_t sxhash( struct cons_pointer ptr ) { + // TODO: Not Yet Implemented + /* TODO: should look at the implementation of Common Lisp sxhash? + * My current implementation of `print` only addresses URL_FILE + * streams. It would be better if it also addressed strings but + * currently it doesn't. Creating a print string of the structure + * and taking the hash of that would be one simple (but not necessarily + * cheap) solution. + */ + /* TODO: sbcl's implementation of `sxhash` is in src/compiler/sxhash.lisp + * and is EXTREMELY complex, and essentially has a different dispatch for + * every type of object. It's likely we need to do the same. + */ + return 0; +} + /** * Get the hash value for the cell indicated by this `ptr`; currently only - * implemented for string like things. + * implemented for string like things and integers. */ uint32_t get_hash(struct cons_pointer ptr) { struct cons_space_object *cell = &pointer2cell(ptr); uint32_t result = 0; - switch (cell->tag.value) - { - case KEYTV: - case STRINGTV: - case SYMBOLTV: + switch ( cell->tag.value ) { + case INTEGERTV: + /* Note that we're only hashing on the least significant word of an + * integer. */ + result = cell->payload.integer.value & 0xffffffff; + break; + case KEYTV: + case STRINGTV: + case SYMBOLTV: result = cell->payload.string.hash; - default: - // TODO: Not Yet Implemented - result = 0; + break; + case TRUETV: + result = 1; // arbitrarily + break; + default: + result = sxhash( ptr ); + break; } return result; } +/** + * Free the hashmap indicated by this `pointer`. + */ +void free_hashmap( struct cons_pointer pointer ) { + struct cons_space_object *cell = &pointer2cell( pointer ); + + if ( hashmapp( pointer ) ) { + struct vector_space_object *vso = cell->payload.vectorp.address; + struct hashmap_payload payload = vso->payload.hashmap; + + dec_ref( payload.hash_fn ); + dec_ref( payload.write_acl ); + + for ( int i = 0; i < payload.n_buckets; i++ ) { + debug_printf( DEBUG_ALLOC, + L"Decrementing buckets[%d] of hashmap at 0x%lx\n", i, + cell->payload.vectorp.address ); + dec_ref( payload.buckets[i] ); + } + } else { + debug_printf( DEBUG_ALLOC, L"Non-hashmap passed to `free_hashmap`\n" ); + } +} + /** * A lisp function signature conforming wrapper around get_hash, q.v.. */ @@ -50,7 +106,8 @@ struct cons_pointer lisp_get_hash(struct stack_frame *frame, * `hash_fn` is `NIL`, use the standard hash funtion. */ struct cons_pointer make_hashmap( uint32_t n_buckets, - struct cons_pointer hash_fn ) { + struct cons_pointer hash_fn, + struct cons_pointer write_acl ) { struct cons_pointer result = make_vso( HASHTAG, ( sizeof( struct cons_pointer ) * ( n_buckets + 1 ) ) + ( sizeof( uint32_t ) * 2 ) ); @@ -58,7 +115,9 @@ struct cons_pointer make_hashmap( uint32_t n_buckets, struct hashmap_payload *payload = (struct hashmap_payload *)&pointer_to_vso( result )->payload; - payload->hash_fn = hash_fn; + payload->hash_fn = inc_ref(hash_fn); + payload->write_acl = inc_ref(write_acl); + payload->n_buckets = n_buckets; for ( int i = 0; i < n_buckets; i++ ) { payload->buckets[i] = NIL; @@ -68,28 +127,170 @@ struct cons_pointer make_hashmap( uint32_t n_buckets, } /** - * If this `ptr` is a pointer to a hashmap, return a new identical hashmap; - * else return `NIL`. TODO: should return an exception. + * Lisp funtion of up to four args (all optional), where + * + * first is expected to be an integer, the number of buckets, or nil; + * second is expected to be a hashing function, or nil; + * third is expected to be an assocable, or nil; + * fourth is a list of user tokens, to be used as a write ACL, or nil. */ -struct cons_pointer clone_hashmap(struct cons_pointer ptr) { - struct cons_pointer result = NIL; +struct cons_pointer lisp_make_hashmap( struct stack_frame *frame, + struct cons_pointer frame_pointer, + struct cons_pointer env ) { + uint32_t n = 32; + struct cons_pointer hash_fn = NIL; + struct cons_pointer result = NIL; - if (hashmapp(ptr)) { - struct vector_space_object *from = pointer_to_vso( ptr ); + if ( frame->args > 0 ) { + if ( integerp( frame->arg[0] ) ) { + n = to_long_int( frame->arg[0] ) % UINT32_MAX; + } else if ( !nilp( frame->arg[0] ) ) { + result = make_exception( + c_string_to_lisp_string( L"First arg to `hashmap`, if passed, must " + L"be an integer or `nil`.`" ), + NIL ); + } + } + if ( frame->args > 1 ) { + hash_fn = frame->arg[1]; + } - if ( from != NULL ) { - struct hashmap_payload *from_pl = (struct hashmap_payload*)from->payload; - result = make_hashmap( from_pl->n_buckets, from_pl->hash_fn); - struct vector_space_object *to = pointer_to_vso(result); - struct hashmap_payload *to_pl = (struct hashmap_payload*)to->payload; + if ( nilp( result ) ) { + /* if there are fewer than 4 args, then arg[3] ought to be nil anyway, which + * is fine */ + result = make_hashmap( n, hash_fn, frame->arg[3] ); + struct vector_space_object *map = pointer_to_vso( result ); - for (int i = 0; i < to_pl->n_buckets; i++) { - to_pl->buckets[i] = from_pl->buckets[i]; - inc_ref(to_pl->buckets[i]); - } + if ( frame->args > 2 && + truep( authorised( result, map->payload.hashmap.write_acl ) ) ) { + // then arg[2] ought to be an assoc list which we should iterate down + // populating the hashmap. + for ( struct cons_pointer cursor = frame->arg[2]; !nilp( cursor ); + cursor = c_cdr( cursor ) ) { + struct cons_pointer pair = c_car( cursor ); + struct cons_pointer key = c_car( pair ); + struct cons_pointer val = c_cdr( pair ); + + uint32_t bucket_no = + get_hash( key ) % + ( (struct hashmap_payload *)&( map->payload ) )->n_buckets; + + map->payload.hashmap.buckets[bucket_no] = + inc_ref( make_cons( make_cons( key, val ), + map->payload.hashmap.buckets[bucket_no] )); } } + } - return result; + return result; +} + +/** + * If this `ptr` is a pointer to a hashmap, return a new identical hashmap; + * else return `NIL`. TODO: should return an exception if ptr is not a + * readable hashmap. + */ +struct cons_pointer clone_hashmap( struct cons_pointer ptr ) { + struct cons_pointer result = NIL; + + if ( truep( authorised( ptr, NIL ) ) ) { + if ( hashmapp( ptr ) ) { + struct vector_space_object *from = pointer_to_vso( ptr ); + + if ( from != NULL ) { + struct hashmap_payload from_pl = from->payload.hashmap; + result = make_hashmap( from_pl.n_buckets, from_pl.hash_fn, from_pl.write_acl ); + struct vector_space_object *to = pointer_to_vso( result ); + struct hashmap_payload to_pl = to->payload.hashmap; + + for ( int i = 0; i < to_pl.n_buckets; i++ ) { + to_pl.buckets[i] = from_pl.buckets[i]; + inc_ref( to_pl.buckets[i] ); + } + } + } + } + // TODO: else exception? + + return result; +} + +/** + * Store this `val` as the value of this `key` in this hashmap `mapp`. If + * current user is authorised to write to this hashmap, modifies the hashmap and + * returns it; if not, clones the hashmap, modifies the clone, and returns that. + */ +struct cons_pointer hashmap_put( struct cons_pointer mapp, + struct cons_pointer key, + struct cons_pointer val ) { + // TODO: if current user has write access to this hashmap + if ( hashmapp( mapp ) && !nilp( key ) ) { + struct vector_space_object *map = pointer_to_vso( mapp ); + + if (nilp(authorised(mapp, map->payload.hashmap.write_acl))) { + mapp = clone_hashmap( mapp); + map = pointer_to_vso( mapp ); + } + uint32_t bucket_no = + get_hash( key ) % + map->payload.hashmap.n_buckets; + + map->payload.hashmap.buckets[bucket_no] = + inc_ref( make_cons( make_cons( key, val ), + map->payload.hashmap.buckets[bucket_no] )); + } + + return mapp; +} + +/** + * Expects `frame->arg[1]` to be a hashmap or namespace; `frame->arg[2]` to be + * a string-like-thing (perhaps necessarily a keyword); frame->arg[3] to be + * any value. If + * current user is authorised to write to this hashmap, modifies the hashmap and + * returns it; if not, clones the hashmap, modifies the clone, and returns that. + */ +struct cons_pointer lisp_hashmap_put( struct stack_frame *frame, + struct cons_pointer frame_pointer, + struct cons_pointer env ) { + struct cons_pointer mapp = frame->arg[0]; + struct cons_pointer key = frame->arg[1]; + struct cons_pointer val = frame->arg[2]; + + return hashmap_put(mapp, key, val); +} + +/** + * Copy all key/value pairs in this association list `assoc` into this hashmap `mapp`. If + * current user is authorised to write to this hashmap, modifies the hashmap and + * returns it; if not, clones the hashmap, modifies the clone, and returns that. + */ +struct cons_pointer hashmap_put_all( struct cons_pointer mapp, + struct cons_pointer assoc ) { + // TODO: if current user has write access to this hashmap + if ( hashmapp( mapp ) && !nilp( assoc ) ) { + struct vector_space_object *map = pointer_to_vso( mapp ); + + if ( hashmapp( mapp ) && consp( assoc ) ) { + for ( struct cons_pointer pair = c_car( assoc ); !nilp( pair ); + pair = c_car( assoc ) ) { + /* TODO: this is really hammering the memory management system, because + * it will make a new lone for every key/value pair added. Fix. */ + mapp = hashmap_put( mapp, c_car( pair ), c_cdr( pair ) ); + } + } + } + + return mapp; +} + +/** + * Lisp function expecting two arguments, a hashmap and an assoc list. Copies all + * key/value pairs from the assoc list into the map. + */ +struct cons_pointer lisp_hashmap_put_all( struct stack_frame *frame, + struct cons_pointer frame_pointer, + struct cons_pointer env ) { + return hashmap_put_all( frame->arg[0], frame->arg[1] ); } diff --git a/src/memory/hashmap.h b/src/memory/hashmap.h index 813211b..579b56d 100644 --- a/src/memory/hashmap.h +++ b/src/memory/hashmap.h @@ -15,24 +15,24 @@ #include "memory/consspaceobject.h" #include "memory/vectorspace.h" -/** - * The payload of a hashmap. The number of buckets is assigned at run-time, - * and is stored in n_buckets. Each bucket is something ASSOC can consume: - * i.e. either an assoc list or a further hashmap. - */ -struct hashmap_payload { - struct cons_pointer hash_fn; - uint32_t n_buckets; - uint32_t unused; /* for word alignment and possible later expansion */ - struct cons_pointer buckets[]; -}; +uint32_t get_hash( struct cons_pointer ptr ); -uint32_t get_hash(struct cons_pointer ptr); +void free_hashmap( struct cons_pointer ptr ); -struct cons_pointer lisp_get_hash(struct stack_frame *frame, - struct cons_pointer frame_pointer, - struct cons_pointer env); +struct cons_pointer lisp_get_hash( struct stack_frame *frame, + struct cons_pointer frame_pointer, + struct cons_pointer env ); -struct cons_pointer make_hashmap( uint32_t n_buckets, struct cons_pointer hash_fn); +struct cons_pointer lisp_hashmap_put( struct stack_frame *frame, + struct cons_pointer frame_pointer, + struct cons_pointer env ); + +struct cons_pointer lisp_hashmap_put_all( struct stack_frame *frame, + struct cons_pointer frame_pointer, + struct cons_pointer env ); + +struct cons_pointer lisp_make_hashmap( struct stack_frame *frame, + struct cons_pointer frame_pointer, + struct cons_pointer env ); #endif \ No newline at end of file diff --git a/src/memory/vectorspace.c b/src/memory/vectorspace.c index 480effb..b3e64c6 100644 --- a/src/memory/vectorspace.c +++ b/src/memory/vectorspace.c @@ -22,6 +22,8 @@ #include "conspage.h" #include "consspaceobject.h" #include "debug.h" +#include "hashmap.h" +#include "stack.h" #include "vectorspace.h" @@ -112,3 +114,27 @@ struct cons_pointer make_vso( char *tag, uint64_t payload_size ) { return result; } + +/** for vector space pointers, free the actual vector-space + * object. Dangerous! */ + +void free_vso( struct cons_pointer pointer ) { + struct cons_space_object * cell = &pointer2cell( pointer); + + debug_printf( DEBUG_ALLOC, L"About to free vector-space object at 0x%lx\n", + cell->payload.vectorp.address ); + struct vector_space_object *vso = cell->payload.vectorp.address; + + switch ( vso->header.tag.value ) { + case HASHTV: + free_hashmap( pointer ); + break; + case STACKFRAMETV: + free_stack_frame( get_stack_frame( pointer ) ); + break; + } + + free( (void *)cell->payload.vectorp.address ); + debug_printf( DEBUG_ALLOC, L"Freed vector-space object at 0x%lx\n", + cell->payload.vectorp.address ); +} \ No newline at end of file diff --git a/src/memory/vectorspace.h b/src/memory/vectorspace.h index 15740ac..ed050bc 100644 --- a/src/memory/vectorspace.h +++ b/src/memory/vectorspace.h @@ -18,6 +18,7 @@ #include #include "consspaceobject.h" +#include "hashmap.h" #ifndef __vectorspace_h #define __vectorspace_h @@ -58,6 +59,8 @@ struct cons_pointer make_vso( char *tag, uint64_t payload_size ); +void free_vso(struct cons_pointer pointer); + /** * the header which forms the start of every vector space object. */ @@ -75,6 +78,27 @@ struct vector_space_header { uint64_t size; }; +/** + * The payload of a hashmap. The number of buckets is assigned at run-time, + * and is stored in n_buckets. Each bucket is something ASSOC can consume: + * i.e. either an assoc list or a further hashmap. + */ +struct hashmap_payload { + struct cons_pointer + hash_fn; /* function for hashing values in this hashmap, or `NIL` to use + the default hashing function */ + struct cons_pointer write_acl; /* it seems to me that it is likely that the + * principal difference between a hashmap and a + * namespace is that a hashmap has a write ACL + * of `NIL`, meaning not writeable by anyone */ + uint32_t n_buckets; /* number of hash buckets */ + uint32_t unused; /* for word alignment and possible later expansion */ + struct cons_pointer + buckets[]; /* actual hash buckets, which should be `NIL` + * or assoc lists or (possibly) further hashmaps. */ +}; + + /** a vector_space_object is just a vector_space_header followed by a * lump of bytes; what we deem to be in there is a function of the tag, * and at this stage we don't have a good picture of what these may be. @@ -87,7 +111,11 @@ struct vector_space_object { struct vector_space_header header; /** we'll malloc `size` bytes for payload, `payload` is just the first of these. * \todo this is almost certainly not idiomatic C. */ - char payload; + union { + /** the payload considered as bytes */ + char bytes; + struct hashmap_payload hashmap; + } payload; }; #endif diff --git a/src/ops/intern.c b/src/ops/intern.c index cf86e6b..802bc82 100644 --- a/src/ops/intern.c +++ b/src/ops/intern.c @@ -23,6 +23,7 @@ #include "consspaceobject.h" #include "debug.h" #include "equal.h" +#include "hashmap.h" #include "lispops.h" #include "map.h" #include "print.h" @@ -107,8 +108,10 @@ struct cons_pointer c_assoc( struct cons_pointer key, break; } } - } else if (vectorpointp( store)) { + } else if (hashmapp( store)) { result = assoc_in_map( key, store); + } else { + result = throw_exception(c_string_to_lisp_string(L"Store is of unknown type"), NIL); } debug_print( L"c_assoc returning ", DEBUG_BIND); From 4fc9545be8610b94b4bc55e19cbcce696f576446 Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Mon, 16 Aug 2021 18:55:02 +0100 Subject: [PATCH 09/28] Hashmaps sort-of work but there are still bugs and one test is failing that wasn't. --- src/init.c | 8 +- src/io/print.c | 46 +++---- src/io/read.c | 48 +++---- src/memory/dump.c | 8 +- src/memory/hashmap.c | 70 +++++++++- src/memory/hashmap.h | 17 +++ src/memory/map.c | 289 --------------------------------------- src/memory/map.h | 96 ------------- src/memory/vectorspace.h | 8 +- src/ops/intern.c | 8 +- src/ops/lispops.c | 23 +++- src/ops/lispops.h | 72 +++++----- 12 files changed, 206 insertions(+), 487 deletions(-) delete mode 100644 src/memory/map.c delete mode 100644 src/memory/map.h diff --git a/src/init.c b/src/init.c index dbfdd5d..7b1649c 100644 --- a/src/init.c +++ b/src/init.c @@ -23,10 +23,10 @@ #include "conspage.h" #include "consspaceobject.h" #include "debug.h" +#include "hashmap.h" #include "intern.h" #include "io.h" #include "lispops.h" -#include "map.h" #include "meta.h" #include "peano.h" #include "print.h" @@ -225,8 +225,10 @@ int main( int argc, char *argv[] ) { bind_function( L"equal", &lisp_equal ); bind_function( L"eval", &lisp_eval ); bind_function( L"exception", &lisp_exception ); + bind_function( L"gethash", &lisp_get_hash); + bind_function(L"hashmap", lisp_make_hashmap); bind_function( L"inspect", &lisp_inspect ); - bind_function( L"make-map", &lisp_make_map); + bind_function( L"keys", &lisp_keys); bind_function( L"meta", &lisp_metadata ); bind_function( L"metadata", &lisp_metadata ); bind_function( L"multiply", &lisp_multiply ); @@ -235,6 +237,8 @@ int main( int argc, char *argv[] ) { bind_function( L"open", &lisp_open ); bind_function( L"print", &lisp_print ); bind_function( L"progn", &lisp_progn ); + bind_function( L"put", lisp_hashmap_put); + bind_function( L"put-all", &lisp_hashmap_put_all); bind_function( L"read", &lisp_read ); bind_function( L"read-char", &lisp_read_char ); bind_function( L"repl", &lisp_repl ); diff --git a/src/io/print.c b/src/io/print.c index c68c03e..3f33252 100644 --- a/src/io/print.c +++ b/src/io/print.c @@ -19,9 +19,9 @@ #include "conspage.h" #include "consspaceobject.h" +#include "hashmap.h" #include "integer.h" #include "intern.h" -#include "map.h" #include "stack.h" #include "print.h" #include "psse_time.h" @@ -88,40 +88,38 @@ void print_list( URL_FILE * output, struct cons_pointer pointer ) { url_fputws( L")", output ); } +void print_map( URL_FILE *output, struct cons_pointer map ) { + if ( hashmapp( map ) ) { + struct vector_space_object *vso = pointer_to_vso( map ); -void print_map( URL_FILE * output, struct cons_pointer map) { - if ( vectorpointp( map)) { - struct vector_space_object *vso = pointer_to_vso( map); + url_fputwc( btowc( '{' ), output ); - if ( mapp( vso ) ) { - url_fputwc( btowc( '{' ), output ); + for ( struct cons_pointer ks = hashmap_keys( map ); !nilp( ks ); + ks = c_cdr( ks ) ) { + struct cons_pointer key = c_car( ks); + print( output, key ); + url_fputwc( btowc( ' ' ), output ); + print( output, hashmap_get( map, key ) ); - for ( struct cons_pointer ks = keys( map); - !nilp( ks); ks = c_cdr( ks)) { - print( output, c_car( ks)); - url_fputwc( btowc( ' ' ), output ); - print( output, c_assoc( c_car( ks), map)); - - if ( !nilp( c_cdr( ks))) { - url_fputws( L", ", output ); - } - } - - url_fputwc( btowc( '}' ), output ); - } + if ( !nilp( c_cdr( ks ) ) ) { + url_fputws( L", ", output ); + } } + + url_fputwc( btowc( '}' ), output ); + } } - void print_vso( URL_FILE * output, struct cons_pointer pointer) { - struct vector_space_object *vso = - pointer2cell( pointer ).payload.vectorp.address; - + struct vector_space_object *vso = pointer_to_vso(pointer); switch ( vso->header.tag.value) { - case MAPTV: + case HASHTV: print_map( output, pointer); break; // \todo: others. + default: + fwprintf( stderr, L"Unrecognised vector-space type '%d'\n", + vso->header.tag.value ); } } diff --git a/src/io/read.c b/src/io/read.c index 0f32815..ede44ad 100644 --- a/src/io/read.c +++ b/src/io/read.c @@ -20,11 +20,11 @@ #include "consspaceobject.h" #include "debug.h" #include "dump.h" +#include "hashmap.h" #include "integer.h" #include "intern.h" #include "io.h" #include "lispops.h" -#include "map.h" #include "peano.h" #include "print.h" #include "ratio.h" @@ -323,37 +323,39 @@ struct cons_pointer read_list( struct stack_frame *frame, return result; } - struct cons_pointer read_map( struct stack_frame *frame, - struct cons_pointer frame_pointer, - URL_FILE * input, wint_t initial ) { - struct cons_pointer result = make_empty_map( NIL); - wint_t c = initial; + struct cons_pointer frame_pointer, + URL_FILE *input, wint_t initial ) { + // set write ACL to true whilst creating to prevent GC churn + struct cons_pointer result = make_hashmap( DFLT_HASHMAP_BUCKETS, NIL, TRUE ); + wint_t c = initial; - while ( c != L'}' ) { - struct cons_pointer key = - read_continuation( frame, frame_pointer, input, c ); + while ( c != L'}' ) { + struct cons_pointer key = + read_continuation( frame, frame_pointer, input, c ); - /* skip whitespace */ - for (c = url_fgetwc( input ); - iswblank( c ) || iswcntrl( c ); - c = url_fgetwc( input )); + /* skip whitespace */ + for ( c = url_fgetwc( input ); iswblank( c ) || iswcntrl( c ); + c = url_fgetwc( input ) ) + ; - struct cons_pointer value = - read_continuation( frame, frame_pointer, input, c ); + struct cons_pointer value = + read_continuation( frame, frame_pointer, input, c ); - /* skip commaa and whitespace at this point. */ - for (c = url_fgetwc( input ); - c == L',' || iswblank( c ) || iswcntrl( c ); - c = url_fgetwc( input )); + /* skip commaa and whitespace at this point. */ + for ( c = url_fgetwc( input ); c == L',' || iswblank( c ) || iswcntrl( c ); + c = url_fgetwc( input ) ) + ; - result = merge_into_map( result, make_cons( make_cons( key, value), NIL)); - } + result = hashmap_put( result, key, value ); + } - return result; + // default write ACL for maps should be NIL. + pointer_to_vso( result )->payload.hashmap.write_acl = NIL; + + return result; } - /** * Read a string. This means either a string delimited by double quotes * (is_quoted == true), in which case it may contain whitespace but may diff --git a/src/memory/dump.c b/src/memory/dump.c index 074d1c4..b992bb2 100644 --- a/src/memory/dump.c +++ b/src/memory/dump.c @@ -21,8 +21,8 @@ #include "conspage.h" #include "consspaceobject.h" #include "debug.h" +#include "hashmap.h" #include "intern.h" -#include "map.h" #include "print.h" #include "stack.h" #include "vectorspace.h" @@ -141,14 +141,12 @@ void dump_object( URL_FILE * output, struct cons_pointer pointer ) { L"\t\tVector space object of type %4.4s (%d), payload size %d bytes\n", &vso->header.tag.bytes, vso->header.tag.value, vso->header.size ); - if ( stackframep( vso ) ) { - dump_frame( output, pointer ); - } + switch ( vso->header.tag.value ) { case STACKFRAMETV: dump_frame( output, pointer ); break; - case MAPTV: + case HASHTV: dump_map( output, pointer); break; } diff --git a/src/memory/hashmap.c b/src/memory/hashmap.c index 9be7d64..11a03f0 100644 --- a/src/memory/hashmap.c +++ b/src/memory/hashmap.c @@ -11,6 +11,8 @@ #include "arith/peano.h" #include "authorise.h" #include "debug.h" +#include "intern.h" +#include "memory/conspage.h" #include "memory/consspaceobject.h" #include "memory/hashmap.h" #include "memory/vectorspace.h" @@ -81,10 +83,12 @@ void free_hashmap( struct cons_pointer pointer ) { dec_ref( payload.write_acl ); for ( int i = 0; i < payload.n_buckets; i++ ) { - debug_printf( DEBUG_ALLOC, - L"Decrementing buckets[%d] of hashmap at 0x%lx\n", i, - cell->payload.vectorp.address ); - dec_ref( payload.buckets[i] ); + if ( !nilp( payload.buckets[i] ) ) { + debug_printf( DEBUG_ALLOC, + L"Decrementing bucket [%d] of hashmap at 0x%lx\n", i, + cell->payload.vectorp.address ); + dec_ref( payload.buckets[i] ); + } } } else { debug_printf( DEBUG_ALLOC, L"Non-hashmap passed to `free_hashmap`\n" ); @@ -137,7 +141,7 @@ struct cons_pointer make_hashmap( uint32_t n_buckets, struct cons_pointer lisp_make_hashmap( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ) { - uint32_t n = 32; + uint32_t n = DFLT_HASHMAP_BUCKETS; struct cons_pointer hash_fn = NIL; struct cons_pointer result = NIL; @@ -185,6 +189,8 @@ struct cons_pointer lisp_make_hashmap( struct stack_frame *frame, return result; } + + /** * If this `ptr` is a pointer to a hashmap, return a new identical hashmap; * else return `NIL`. TODO: should return an exception if ptr is not a @@ -243,6 +249,19 @@ struct cons_pointer hashmap_put( struct cons_pointer mapp, return mapp; } +struct cons_pointer hashmap_get( struct cons_pointer mapp, + struct cons_pointer key ) { + struct cons_pointer result = NIL; + if ( hashmapp( mapp ) && truep( authorised( mapp, NIL ) ) && !nilp( key ) ) { + struct vector_space_object *map = pointer_to_vso( mapp ); + uint32_t bucket_no = get_hash( key ) % map->payload.hashmap.n_buckets; + + result = c_assoc( key, map->payload.hashmap.buckets[bucket_no] ); + } + + return result; +} + /** * Expects `frame->arg[1]` to be a hashmap or namespace; `frame->arg[2]` to be * a string-like-thing (perhaps necessarily a keyword); frame->arg[3] to be @@ -294,3 +313,44 @@ struct cons_pointer lisp_hashmap_put_all( struct stack_frame *frame, return hashmap_put_all( frame->arg[0], frame->arg[1] ); } +/** + * return a flat list of all the keys in the hashmap indicated by `map`. + */ +struct cons_pointer hashmap_keys( struct cons_pointer mapp) { + struct cons_pointer result = NIL; + if ( hashmapp( mapp ) && truep( authorised( mapp, NIL ) )) { + struct vector_space_object *map = pointer_to_vso( mapp ); + + for (int i = 0; i < map->payload.hashmap.n_buckets; i++) { + for (struct cons_pointer c = map->payload.hashmap.buckets[i]; + !nilp(c); + c = c_cdr(c)) { + result = make_cons(c_car( c_car(c)), result); + } + + } + } + + return result; +} + +struct cons_pointer lisp_hashmap_keys( struct stack_frame *frame, + struct cons_pointer frame_pointer, + struct cons_pointer env ) { + return hashmap_keys( frame->arg[0] ); +} + +void dump_map( URL_FILE *output, struct cons_pointer pointer ) { + struct hashmap_payload *payload = &pointer_to_vso( pointer )->payload.hashmap; + url_fwprintf( output, L"Hashmap with %d buckets:\n", payload->n_buckets ); + url_fwprintf( output, L"\tHash function: " ); + print( output, payload->hash_fn ); + url_fwprintf( output, L"\n\tWrite ACL: " ); + print( output, payload->write_acl ); + url_fwprintf( output, L"\n\tBuckets:" ); + for ( int i = 0; i < payload->n_buckets; i++ ) { + url_fwprintf( output, L"\n\t\t[%d]: ", i ); + print( output, payload->buckets[i] ); + } + url_fwprintf( output, L"\n" ); +} diff --git a/src/memory/hashmap.h b/src/memory/hashmap.h index 579b56d..4602f3e 100644 --- a/src/memory/hashmap.h +++ b/src/memory/hashmap.h @@ -15,14 +15,27 @@ #include "memory/consspaceobject.h" #include "memory/vectorspace.h" +#define DFLT_HASHMAP_BUCKETS 32 + uint32_t get_hash( struct cons_pointer ptr ); void free_hashmap( struct cons_pointer ptr ); +void dump_map( URL_FILE *output, struct cons_pointer pointer ); + +struct cons_pointer hashmap_get( struct cons_pointer mapp, + struct cons_pointer key ); + +struct cons_pointer hashmap_put( struct cons_pointer mapp, + struct cons_pointer key, + struct cons_pointer val ); + struct cons_pointer lisp_get_hash( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ); +struct cons_pointer hashmap_keys( struct cons_pointer map ); + struct cons_pointer lisp_hashmap_put( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ); @@ -35,4 +48,8 @@ struct cons_pointer lisp_make_hashmap( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ); +struct cons_pointer make_hashmap( uint32_t n_buckets, + struct cons_pointer hash_fn, + struct cons_pointer write_acl ); + #endif \ No newline at end of file diff --git a/src/memory/map.c b/src/memory/map.c deleted file mode 100644 index cbad3df..0000000 --- a/src/memory/map.c +++ /dev/null @@ -1,289 +0,0 @@ -/* - * map.c - * - * An immutable hashmap in vector space. - * - * (c) 2019 Simon Brooke - * Licensed under GPL version 2.0, or, at your option, any later version. - */ - -#include - -#include "consspaceobject.h" -#include "conspage.h" -#include "debug.h" -#include "dump.h" -#include "fopen.h" -#include "intern.h" -#include "io.h" -#include "lookup3.h" -#include "map.h" -#include "print.h" -#include "vectorspace.h" - -/* \todo: a lot of this will be inherited by namespaces, regularities and - * homogeneities. Exactly how I don't yet know. */ - -/** - * Get a hash value for this key. - */ -uint32_t get_hash_32(struct cons_pointer f, struct cons_pointer key) { - uint32_t result = 0; - int l = c_length(key); - - if (keywordp(key) || stringp(key) || symbolp( key)) { - if ( l > 0) { - uint32_t buffer[l]; - - if (!nilp(f)) { - fputws(L"Custom hashing functions are not yet implemented.\n", stderr); - } - for (int i = 0; i < l; i++) { - buffer[i] = (uint32_t)pointer2cell(key).payload.string.character; - } - - result = hashword( buffer, l, 0); - } - } else { - fputws(L"Hashing is thus far implemented only for keys, strings and symbols.\n", stderr); - } - - return result; -} - -/** - * get the actual map object from this `pointer`, or NULL if - * `pointer` is not a map pointer. - */ -struct map_payload *get_map_payload( struct cons_pointer pointer ) { - struct map_payload *result = NULL; - struct vector_space_object *vso = - pointer2cell( pointer ).payload.vectorp.address; - - if (vectorpointp(pointer) && mapp( vso ) ) { - result = ( struct map_payload * ) &( vso->payload ); - debug_printf( DEBUG_BIND, - L"get_map_payload: all good, returning %p\n", result ); - } else { - debug_print( L"get_map_payload: fail, returning NULL\n", DEBUG_BIND ); - } - - return result; -} - - -/** - * Make an empty immutable map, and return it. - * - * @param hash_function a pointer to a function of one argument, which - * returns an integer; or (more usually) `nil`. - * @return the new map, or NULL if memory is exhausted. - */ -struct cons_pointer make_empty_map( struct cons_pointer hash_function ) { - debug_print( L"Entering make_empty_map\n", DEBUG_BIND ); - struct cons_pointer result = - make_vso( MAPTAG, sizeof( struct map_payload ) ); - - if ( !nilp( result ) ) { - struct map_payload *payload = get_map_payload( result ); - - payload->hash_function = functionp( hash_function) ? hash_function : NIL; - inc_ref(hash_function); - - for ( int i = 0; i < BUCKETSINMAP; i++) { - payload->buckets[i] = NIL; - } - } - - debug_print( L"Leaving make_empty_map\n", DEBUG_BIND ); - return result; -} - - -struct cons_pointer make_duplicate_map( struct cons_pointer parent) { - struct cons_pointer result = NIL; - struct map_payload * parent_payload = get_map_payload(parent); - - if (parent_payload != NULL) { - result = - make_vso( MAPTAG, sizeof( struct map_payload ) ); - - if ( !nilp( result ) ) { - struct map_payload *payload = get_map_payload( result ); - - payload->hash_function = parent_payload->hash_function; - inc_ref(payload->hash_function); - - for ( int i = 0; i < BUCKETSINMAP; i++) { - payload->buckets[i] = parent_payload->buckets[i]; - inc_ref(payload->buckets[i]); - } - } - } - - return result; -} - - -struct cons_pointer bind_in_map( struct cons_pointer parent, - struct cons_pointer key, - struct cons_pointer value) { - struct cons_pointer result = make_duplicate_map(parent); - - if ( !nilp( result)) { - struct map_payload * payload = get_map_payload( result ); - int bucket = get_hash_32(payload->hash_function, key) % BUCKETSINMAP; - - payload->buckets[bucket] = make_cons( - make_cons(key, value), payload->buckets[bucket]); - - inc_ref(payload->buckets[bucket]); - } - - return result; -} - - -struct cons_pointer keys( struct cons_pointer store) { - debug_print( L"Entering keys\n", DEBUG_BIND ); - struct cons_pointer result = NIL; - - struct cons_space_object cell = pointer2cell( store ); - - switch (pointer2cell( store ).tag.value) { - case CONSTV: - for (struct cons_pointer c = store; !nilp(c); c = c_cdr(c)) { - result = make_cons( c_car( c_car( c)), result); - } - break; - case VECTORPOINTTV: { - struct vector_space_object *vso = - pointer2cell( store ).payload.vectorp.address; - - if ( mapp( vso ) ) { - struct map_payload * payload = get_map_payload( store ); - - for (int bucket = 0; bucket < BUCKETSINMAP; bucket++) { - for (struct cons_pointer c = payload->buckets[bucket]; - !nilp(c); c = c_cdr(c)) { - debug_print( L"keys: c is ", DEBUG_BIND); - debug_print_object( c, DEBUG_BIND); - - result = make_cons( c_car( c_car( c)), result); - debug_print( L"; result is ", DEBUG_BIND); - debug_print_object( result, DEBUG_BIND); - debug_println( DEBUG_BIND); - } - } - } - } - break; - } - debug_print( L"keys returning ", DEBUG_BIND ); - debug_print_object( result, DEBUG_BIND ); - debug_println( DEBUG_BIND); - - return result; -} - -/** - * Return a new map which represents the merger of `to_merge` into - * `parent`. `parent` must be a map, but `to_merge` may be a map or - * an assoc list. - * - * @param parent a map; - * @param to_merge an association from which key/value pairs will be merged. - * @result a new map, containing all key/value pairs from `to_merge` - * together with those key/value pairs from `parent` whose keys did not - * collide. - */ -struct cons_pointer merge_into_map( struct cons_pointer parent, - struct cons_pointer to_merge) { - debug_print( L"Entering merge_into_map\n", DEBUG_BIND ); - struct cons_pointer result = make_duplicate_map(parent); - - if (!nilp(result)) { - struct map_payload *payload = get_map_payload( result ); - for (struct cons_pointer c = keys(to_merge); - !nilp(c); c = c_cdr(c)) { - struct cons_pointer key = c_car( c); - int bucket = get_hash_32(payload->hash_function, key) % BUCKETSINMAP; - - payload->buckets[bucket] = make_cons( - make_cons( key, c_assoc( key, to_merge)), - payload->buckets[bucket]); - } - } - - debug_print( L"Leaving merge_into_map\n", DEBUG_BIND ); - - return result; -} - - -struct cons_pointer assoc_in_map( struct cons_pointer key, - struct cons_pointer map) { - debug_print( L"Entering assoc_in_map\n", DEBUG_BIND ); - struct cons_pointer result = NIL; - struct map_payload *payload = get_map_payload( map ); - - if (payload != NULL) { - int bucket = get_hash_32(payload->hash_function, key) % BUCKETSINMAP; - result = c_assoc(key, payload->buckets[bucket]); - } - - debug_print( L"assoc_in_map returning ", DEBUG_BIND ); - debug_print_object( result, DEBUG_BIND); - debug_println( DEBUG_BIND); - - return result; -} - - -/** - * Function: create a map initialised with key/value pairs from my - * first argument. - * - * * (make-map) - * * (make-map store) - * - * @param frame the stack frame in which the expression is to be interpreted; - * @param frame_pointer a pointer to my stack_frame. - * @param env the environment in which it is to be intepreted. - * @return a new containing all the key/value pairs from store. - */ -struct cons_pointer -lisp_make_map( struct stack_frame *frame, struct cons_pointer frame_pointer, - struct cons_pointer env ) { - return merge_into_map( make_empty_map( NIL), frame->arg[0]); -} - -/** - * Dump a map to this stream for debugging - * @param output the stream - * @param map_pointer the pointer to the frame - */ -void dump_map( URL_FILE * output, struct cons_pointer map_pointer ) { - struct vector_space_object *vso = - pointer2cell( map_pointer ).payload.vectorp.address; - - if (vectorpointp(map_pointer) && mapp( vso ) ) { - struct map_payload *payload = get_map_payload( map_pointer ); - - if ( payload != NULL ) { - url_fputws( L"Immutable map; hash function: ", output ); - - if (nilp(payload->hash_function)) { - url_fputws( L"default", output); - } else { - dump_object( output, payload->hash_function); - } - - for (int i = 0; i < BUCKETSINMAP; i++) { - url_fwprintf(output, L"\n\tBucket %d: ", i); - print( output, payload->buckets[i]); - } - } - } -} - diff --git a/src/memory/map.h b/src/memory/map.h deleted file mode 100644 index c9b5cfc..0000000 --- a/src/memory/map.h +++ /dev/null @@ -1,96 +0,0 @@ -/* - * map.h - * - * An immutable hashmap in vector space. - * - * (c) 2019 Simon Brooke - * Licensed under GPL version 2.0, or, at your option, any later version. - */ - -#ifndef __psse_map_h -#define __psse_map_h - -#include "consspaceobject.h" -#include "conspage.h" - -/** - * macros for the tag of a mutable map. - */ -#define MAPTAG "IMAP" -#define MAPTV 1346456905 - -/** - * Number of buckets in a single tier map. - */ -#define BUCKETSINMAP 256 - -/** - * Maximum number of entries in an association-list bucket. - */ -#define MAXENTRIESINASSOC 16 - -/** - * true if this vector_space_object is a map, else false. - */ -#define mapp( vso) (((struct vector_space_object *)vso)->header.tag.value == MAPTV) - -/** - * The vector-space payload of a map object. Essentially a vector of - * `BUCKETSINMAP` + 1 `cons_pointer`s, but the first one is considered - * special. - */ -struct map_payload { - /** - * There is a default hash function, which is used if `hash_function` is - * `nil` (which it normally should be); and keywords will probably carry - * their own hash values. But it will be possible to override the hash - * function by putting a function of one argument returning an integer - * here. */ - struct cons_pointer hash_function; - - /** - * Obviously the number of buckets in a map is a trade off, and this may need - * tuning - or it may even be necessary to have different sized base maps. The - * idea here is that the value of a bucket is - * - * 1. `nil`; or - * 2. an association list; or - * 3. a map. - * - * All buckets are initially `nil`. Adding a value to a `nil` bucket returns - * a map with a new bucket in the form of an assoc list. Subsequent additions - * cons new key/value pairs onto the assoc list, until there are - * `MAXENTRIESINASSOC` pairs, at which point if a further value is added to - * the same bucket the bucket returned will be in the form of a second level - * map. My plan is that buckets the first level map will be indexed on the - * first sixteen bits of the hash value, those in the second on the second - * sixteen, and, potentially, so on. - */ - struct cons_pointer buckets[BUCKETSINMAP]; -}; - -uint32_t get_hash_32(struct cons_pointer f, struct cons_pointer key); - -struct map_payload *get_map_payload( struct cons_pointer pointer ); - -struct cons_pointer make_empty_map( struct cons_pointer hash_function ); - -struct cons_pointer bind_in_map( struct cons_pointer parent, - struct cons_pointer key, - struct cons_pointer value); - -struct cons_pointer keys( struct cons_pointer store); - -struct cons_pointer merge_into_map( struct cons_pointer parent, - struct cons_pointer to_merge); - -struct cons_pointer assoc_in_map( struct cons_pointer key, - struct cons_pointer map); - -struct cons_pointer lisp_make_map( struct stack_frame *frame, - struct cons_pointer frame_pointer, - struct cons_pointer env ); - -void dump_map( URL_FILE * output, struct cons_pointer map_pointer ); - -#endif diff --git a/src/memory/vectorspace.h b/src/memory/vectorspace.h index ed050bc..2c163e8 100644 --- a/src/memory/vectorspace.h +++ b/src/memory/vectorspace.h @@ -27,15 +27,17 @@ * part of the implementation structure of a namespace. */ #define HASHTAG "HASH" -#define HASHTV 0 +#define HASHTV 1213415752 #define hashmapp(conspoint)((check_tag(conspoint,HASHTAG))) /* * a namespace (i.e. a binding of names to values, implemented as a hashmap) + * TODO: but note that a namespace is now essentially a hashmap with a write ACL + * whose name is interned. */ #define NAMESPACETAG "NMSP" -#define NAMESPACETV 0 +#define NAMESPACETV 1347636558 #define namespacep(conspoint)(check_tag(conspoint,NAMESPACETAG)) @@ -43,7 +45,7 @@ * a vector of cons pointers. */ #define VECTORTAG "VECT" -#define VECTORTV 0 +#define VECTORTV 1413694806 #define vectorp(conspoint)(check_tag(conspoint,VECTORTAG)) diff --git a/src/ops/intern.c b/src/ops/intern.c index 802bc82..07b9693 100644 --- a/src/ops/intern.c +++ b/src/ops/intern.c @@ -25,7 +25,6 @@ #include "equal.h" #include "hashmap.h" #include "lispops.h" -#include "map.h" #include "print.h" /** @@ -109,7 +108,7 @@ struct cons_pointer c_assoc( struct cons_pointer key, } } } else if (hashmapp( store)) { - result = assoc_in_map( key, store); + result = hashmap_get( store, key); } else { result = throw_exception(c_string_to_lisp_string(L"Store is of unknown type"), NIL); } @@ -140,8 +139,8 @@ struct cons_pointer if (nilp( store) || consp(store)) { result = make_cons( make_cons( key, value ), store ); - } else if (vectorpointp( store)) { - result = bind_in_map( store, key, value); + } else if (hashmapp( store)) { + result = hashmap_put( store, key, value); } debug_print( L"set returning ", DEBUG_BIND); @@ -196,3 +195,4 @@ intern( struct cons_pointer key, struct cons_pointer environment ) { return result; } + diff --git a/src/ops/lispops.c b/src/ops/lispops.c index c96b1be..3a972a5 100644 --- a/src/ops/lispops.c +++ b/src/ops/lispops.c @@ -33,7 +33,6 @@ #include "intern.h" #include "io.h" #include "lispops.h" -#include "map.h" #include "print.h" #include "read.h" #include "stack.h" @@ -378,7 +377,7 @@ struct cons_pointer case VECTORPOINTTV: switch ( pointer_to_vso(fn_pointer)->header.tag.value) { - case MAPTV: + case HASHTV: /* \todo: if arg[0] is a CONS, treat it as a path */ result = c_assoc( eval_form(frame, frame_pointer, @@ -803,6 +802,26 @@ lisp_assoc( struct stack_frame *frame, struct cons_pointer frame_pointer, return c_assoc( frame->arg[0], frame->arg[1] ); } +struct cons_pointer c_keys(struct cons_pointer store) { + struct cons_pointer result = NIL; + + if ( hashmapp( store ) ) { + result = hashmap_keys( store ); + } else if ( consp( store ) ) { + for ( struct cons_pointer c = store; !nilp( c ); c = c_cdr( c ) ) { + result = make_cons( c_car( c ), result ); + } + } + + return result; +} + +struct cons_pointer lisp_keys( struct stack_frame *frame, + struct cons_pointer frame_pointer, + struct cons_pointer env ) { + return c_keys( frame->arg[0]); +} + /** * Function; are these two objects the same object? Shallow, cheap equality. * diff --git a/src/ops/lispops.h b/src/ops/lispops.h index f359252..4669493 100644 --- a/src/ops/lispops.h +++ b/src/ops/lispops.h @@ -26,12 +26,14 @@ * utilities */ +struct cons_pointer c_keys( struct cons_pointer store ); struct cons_pointer c_reverse( struct cons_pointer arg ); -struct cons_pointer -c_progn( struct stack_frame *frame, struct cons_pointer frame_pointer, - struct cons_pointer expressions, struct cons_pointer env ); +struct cons_pointer c_progn( struct stack_frame *frame, + struct cons_pointer frame_pointer, + struct cons_pointer expressions, + struct cons_pointer env ); /** * Useful building block; evaluate this single form in the context of this @@ -56,7 +58,6 @@ struct cons_pointer eval_forms( struct stack_frame *frame, struct cons_pointer list, struct cons_pointer env ); - /* * special forms */ @@ -67,17 +68,21 @@ struct cons_pointer lisp_apply( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ); -struct cons_pointer -lisp_oblist( struct stack_frame *frame, struct cons_pointer frame_pointer, - struct cons_pointer env ); +struct cons_pointer lisp_keys( struct stack_frame *frame, + struct cons_pointer frame_pointer, + struct cons_pointer env ); -struct cons_pointer -lisp_set( struct stack_frame *frame, struct cons_pointer frame_pointer, - struct cons_pointer env ); +struct cons_pointer lisp_oblist( struct stack_frame *frame, + struct cons_pointer frame_pointer, + struct cons_pointer env ); -struct cons_pointer -lisp_set_shriek( struct stack_frame *frame, struct cons_pointer frame_pointer, - struct cons_pointer env ); +struct cons_pointer lisp_set( struct stack_frame *frame, + struct cons_pointer frame_pointer, + struct cons_pointer env ); + +struct cons_pointer lisp_set_shriek( struct stack_frame *frame, + struct cons_pointer frame_pointer, + struct cons_pointer env ); /** * Construct an interpretable function. @@ -90,17 +95,17 @@ struct cons_pointer lisp_lambda( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ); struct cons_pointer lisp_length( struct stack_frame *frame, - struct cons_pointer frame_pointer, - struct cons_pointer env ); + struct cons_pointer frame_pointer, + struct cons_pointer env ); /** * Construct an interpretable special form. * * @param frame the stack frame in which the expression is to be interpreted; * @param env the environment in which it is to be intepreted. */ -struct cons_pointer -lisp_nlambda( struct stack_frame *frame, struct cons_pointer frame_pointer, - struct cons_pointer env ); +struct cons_pointer lisp_nlambda( struct stack_frame *frame, + struct cons_pointer frame_pointer, + struct cons_pointer env ); struct cons_pointer lisp_quote( struct stack_frame *frame, struct cons_pointer frame_pointer, @@ -146,10 +151,9 @@ struct cons_pointer lisp_reverse( struct stack_frame *frame, * @param env My environment (ignored). * @return As a Lisp string, the tag of the object which is the argument. */ -struct cons_pointer -lisp_type( struct stack_frame *frame, struct cons_pointer frame_pointer, - struct cons_pointer env ); - +struct cons_pointer lisp_type( struct stack_frame *frame, + struct cons_pointer frame_pointer, + struct cons_pointer env ); /** * Function; evaluate the forms which are listed in my single argument @@ -161,9 +165,9 @@ lisp_type( struct stack_frame *frame, struct cons_pointer frame_pointer, * @return the value of the last form on the sequence which is my single * argument. */ -struct cons_pointer -lisp_progn( struct stack_frame *frame, struct cons_pointer frame_pointer, - struct cons_pointer env ); +struct cons_pointer lisp_progn( struct stack_frame *frame, + struct cons_pointer frame_pointer, + struct cons_pointer env ); /** * Special form: conditional. Each arg is expected to be a list; if the first @@ -174,22 +178,22 @@ lisp_progn( struct stack_frame *frame, struct cons_pointer frame_pointer, * @param env My environment (ignored). * @return the value of the last form of the first successful clause. */ -struct cons_pointer -lisp_cond( struct stack_frame *frame, struct cons_pointer frame_pointer, - struct cons_pointer env ); +struct cons_pointer lisp_cond( struct stack_frame *frame, + struct cons_pointer frame_pointer, + struct cons_pointer env ); /** * Throw an exception. - * `throw_exception` is a misnomer, because it doesn't obey the calling signature of a - * lisp function; but it is nevertheless to be preferred to make_exception. A - * real `throw_exception`, which does, will be needed. + * `throw_exception` is a misnomer, because it doesn't obey the calling + * signature of a lisp function; but it is nevertheless to be preferred to + * make_exception. A real `throw_exception`, which does, will be needed. */ struct cons_pointer throw_exception( struct cons_pointer message, struct cons_pointer frame_pointer ); -struct cons_pointer -lisp_exception( struct stack_frame *frame, struct cons_pointer frame_pointer, - struct cons_pointer env ); +struct cons_pointer lisp_exception( struct stack_frame *frame, + struct cons_pointer frame_pointer, + struct cons_pointer env ); struct cons_pointer lisp_source( struct stack_frame *frame, struct cons_pointer frame_pointer, From eadb125b83665f60dba28b97e92ebc2bc05c2eed Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Mon, 16 Aug 2021 23:23:03 +0100 Subject: [PATCH 10/28] Hashmaps now *mostly* work --- .gitignore | 2 + src/init.c | 2 +- src/io/io.c | 30 ++++- src/io/io.h | 2 + src/memory/consspaceobject.c | 9 +- src/memory/dump.c | 208 +++++++++++++++++------------------ src/memory/hashmap.c | 1 + src/memory/vectorspace.c | 23 +++- src/ops/lispops.c | 134 ++++++++++++---------- src/ops/lispops.h | 13 +-- 10 files changed, 238 insertions(+), 186 deletions(-) diff --git a/.gitignore b/.gitignore index 3bf3906..a85ac01 100644 --- a/.gitignore +++ b/.gitignore @@ -40,3 +40,5 @@ src/io/fopen hi\.* .vscode/ + +core diff --git a/src/init.c b/src/init.c index 7b1649c..4126783 100644 --- a/src/init.c +++ b/src/init.c @@ -225,7 +225,7 @@ int main( int argc, char *argv[] ) { bind_function( L"equal", &lisp_equal ); bind_function( L"eval", &lisp_eval ); bind_function( L"exception", &lisp_exception ); - bind_function( L"gethash", &lisp_get_hash); + bind_function( L"get-hash", &lisp_get_hash); bind_function(L"hashmap", lisp_make_hashmap); bind_function( L"inspect", &lisp_inspect ); bind_function( L"keys", &lisp_keys); diff --git a/src/io/io.c b/src/io/io.c index 5065044..9976373 100644 --- a/src/io/io.c +++ b/src/io/io.c @@ -177,13 +177,13 @@ wint_t url_fgetwc( URL_FILE * input ) { * E0 to EF hex (224 to 239): first byte of a three-byte sequence. * F0 to FF hex (240 to 255): first byte of a four-byte sequence. */ - if ( c <= 0x07 ) { + if ( c <= 0xf7 ) { count = 1; - } else if ( c >= '0xc2' && c <= '0xdf' ) { + } else if ( c >= 0xc2 && c <= 0xdf ) { count = 2; - } else if ( c >= '0xe0' && c <= '0xef' ) { + } else if ( c >= 0xe0 && c <= 0xef ) { count = 3; - } else if ( c >= '0xf0' && c <= '0xff' ) { + } else if ( c >= 0xf0 && c <= 0xff ) { count = 4; } @@ -395,6 +395,24 @@ void collect_meta( struct cons_pointer stream, char *url ) { cell->payload.stream.meta = meta; } +/** + * Resutn the current default input, or of `inputp` is false, output stream from + * this `env`ironment. + */ +struct cons_pointer get_default_stream( bool inputp, struct cons_pointer env ) { + struct cons_pointer result = NIL; + struct cons_pointer stream_name = + c_string_to_lisp_symbol( inputp ? L"*in*" : L"*out*" ); + + inc_ref( stream_name ); + + result = c_assoc( stream_name, env ); + + dec_ref( stream_name ); + + return result; +} + /** * Function: return a stream open on the URL indicated by the first argument; @@ -423,8 +441,8 @@ lisp_open( struct stack_frame *frame, struct cons_pointer frame_pointer, URL_FILE *stream = url_fopen( url, "r" ); debug_printf( DEBUG_IO, - L"lisp_open: stream @ %d, stream type = %d, stream handle = %d\n", - (int) &stream, (int)stream->type, (int)stream->handle.file); + L"lisp_open: stream @ %ld, stream type = %d, stream handle = %ld\n", + (long int) &stream, (int)stream->type, (long int)stream->handle.file); switch (stream->type) { case CFTYPE_NONE: diff --git a/src/io/io.h b/src/io/io.h index 33f733f..f350c13 100644 --- a/src/io/io.h +++ b/src/io/io.h @@ -21,6 +21,8 @@ URL_FILE *file_to_url_file( FILE * f ); wint_t url_fgetwc( URL_FILE * input ); wint_t url_ungetwc( wint_t wc, URL_FILE * input ); +struct cons_pointer get_default_stream( bool inputp, struct cons_pointer env ); + struct cons_pointer lisp_close( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ); diff --git a/src/memory/consspaceobject.c b/src/memory/consspaceobject.c index ee82956..9e956f4 100644 --- a/src/memory/consspaceobject.c +++ b/src/memory/consspaceobject.c @@ -35,15 +35,15 @@ bool check_tag( struct cons_pointer pointer, char *tag ) { bool result = false; struct cons_space_object cell = pointer2cell( pointer ); - + result = strncmp( &cell.tag.bytes[0], tag, TAGLENGTH ) == 0; if ( result == false ) { - if ( strncmp( &cell.tag.bytes[0], VECTORPOINTTAG, TAGLENGTH ) == 0 ) { + if ( cell.tag.value == VECTORPOINTTV ) { struct vector_space_object *vec = pointer_to_vso( pointer ); if ( vec != NULL ) { - result = strncmp( &vec->header.tag.bytes[0], tag, TAGLENGTH ) == 0; + result = strncmp( &(vec->header.tag.bytes[0]), tag, TAGLENGTH ) == 0; } } } @@ -286,7 +286,7 @@ uint32_t calculate_hash(wint_t c, struct cons_pointer ptr) case KEYTV: case STRINGTV: case SYMBOLTV: - if (nilp(ptr)) + if (nilp(cell->payload.string.cdr)) { result = (uint32_t)c; } @@ -296,6 +296,7 @@ uint32_t calculate_hash(wint_t c, struct cons_pointer ptr) cell->payload.string.hash) & 0xffffffff; } + break; } return result; diff --git a/src/memory/dump.c b/src/memory/dump.c index b992bb2..2dc6658 100644 --- a/src/memory/dump.c +++ b/src/memory/dump.c @@ -23,6 +23,7 @@ #include "debug.h" #include "hashmap.h" #include "intern.h" +#include "io.h" #include "print.h" #include "stack.h" #include "vectorspace.h" @@ -39,12 +40,14 @@ void dump_string_cell( URL_FILE * output, wchar_t *prefix, cell.payload.string.cdr.offset, cell.count ); } else { url_fwprintf( output, - L"\t\t%ls cell: character '%lc' (%d) next at page %d offset %d, count %u\n", + L"\t\t%ls cell: character '%lc' (%d) with hash %d; next at page %d offset %d, count %u\n", prefix, ( wint_t ) cell.payload.string.character, cell.payload.string.character, + cell.payload.string.hash, cell.payload.string.cdr.page, - cell.payload.string.cdr.offset, cell.count ); + cell.payload.string.cdr.offset, + cell.count ); url_fwprintf( output, L"\t\t value: " ); print( output, pointer ); url_fwprintf( output, L"\n" ); @@ -54,108 +57,105 @@ void dump_string_cell( URL_FILE * output, wchar_t *prefix, /** * dump the object at this cons_pointer to this output stream. */ -void dump_object( URL_FILE * output, struct cons_pointer pointer ) { - struct cons_space_object cell = pointer2cell( pointer ); - url_fwprintf( output, - L"\t%4.4s (%d) at page %d, offset %d count %u\n", - cell.tag.bytes, - cell.tag.value, pointer.page, pointer.offset, cell.count ); +void dump_object( URL_FILE *output, struct cons_pointer pointer ) { + struct cons_space_object cell = pointer2cell( pointer ); + url_fwprintf( output, L"\t%4.4s (%d) at page %d, offset %d count %u\n", + cell.tag.bytes, cell.tag.value, pointer.page, pointer.offset, + cell.count ); - switch ( cell.tag.value ) { - case CONSTV: - url_fwprintf( output, - L"\t\tCons cell: car at page %d offset %d, cdr at page %d offset %d, count %u :", - cell.payload.cons.car.page, - cell.payload.cons.car.offset, - cell.payload.cons.cdr.page, - cell.payload.cons.cdr.offset, cell.count ); - print( output, pointer ); - url_fputws( L"\n", output ); - break; - case EXCEPTIONTV: - url_fwprintf( output, L"\t\tException cell: " ); - dump_stack_trace( output, pointer ); - break; - case FREETV: - url_fwprintf( output, - L"\t\tFree cell: next at page %d offset %d\n", - cell.payload.cons.cdr.page, - cell.payload.cons.cdr.offset ); - break; - case INTEGERTV: - url_fwprintf( output, - L"\t\tInteger cell: value %ld, count %u\n", - cell.payload.integer.value, cell.count ); - if ( !nilp( cell.payload.integer.more ) ) { - url_fputws( L"\t\tBIGNUM! More at:\n", output ); - dump_object( output, cell.payload.integer.more ); - } - break; - case LAMBDATV: - url_fwprintf( output, L"\t\t\u03bb cell;\n\t\t args: " ); - print( output, cell.payload.lambda.args ); - url_fwprintf( output, L";\n\t\t\tbody: " ); - print( output, cell.payload.lambda.body ); - url_fputws( L"\n", output ); - break; - case NILTV: - break; - case NLAMBDATV: - url_fwprintf( output, L"\t\tn\u03bb cell; \n\t\targs: " ); - print( output, cell.payload.lambda.args ); - url_fwprintf( output, L";\n\t\t\tbody: " ); - print( output, cell.payload.lambda.body ); - url_fputws( L"\n", output ); - break; - case RATIOTV: - url_fwprintf( output, - L"\t\tRational cell: value %ld/%ld, count %u\n", - pointer2cell( cell.payload.ratio.dividend ). - payload.integer.value, - pointer2cell( cell.payload.ratio.divisor ). - payload.integer.value, cell.count ); - break; - case READTV: - url_fputws( L"\t\tInput stream; metadata: ", output ); - print( output, cell.payload.stream.meta ); - url_fputws( L"\n", output ); - break; - case REALTV: - url_fwprintf( output, L"\t\tReal cell: value %Lf, count %u\n", - cell.payload.real.value, cell.count ); - break; - case STRINGTV: - dump_string_cell( output, L"String", pointer ); - break; - case SYMBOLTV: - dump_string_cell( output, L"Symbol", pointer ); - break; - case TRUETV: - break; - case VECTORPOINTTV:{ - url_fwprintf( output, - L"\t\tPointer to vector-space object at %p\n", - cell.payload.vectorp.address ); - struct vector_space_object *vso = cell.payload.vectorp.address; - url_fwprintf( output, - L"\t\tVector space object of type %4.4s (%d), payload size %d bytes\n", - &vso->header.tag.bytes, vso->header.tag.value, - vso->header.size ); + switch ( cell.tag.value ) { + case CONSTV: + url_fwprintf( output, + L"\t\tCons cell: car at page %d offset %d, cdr at page %d " + L"offset %d, count %u :", + cell.payload.cons.car.page, cell.payload.cons.car.offset, + cell.payload.cons.cdr.page, cell.payload.cons.cdr.offset, + cell.count ); + print( output, pointer ); + url_fputws( L"\n", output ); + break; + case EXCEPTIONTV: + url_fwprintf( output, L"\t\tException cell: " ); + dump_stack_trace( output, pointer ); + break; + case FREETV: + url_fwprintf( output, L"\t\tFree cell: next at page %d offset %d\n", + cell.payload.cons.cdr.page, cell.payload.cons.cdr.offset ); + break; + case INTEGERTV: + url_fwprintf( output, L"\t\tInteger cell: value %ld, count %u\n", + cell.payload.integer.value, cell.count ); + if ( !nilp( cell.payload.integer.more ) ) { + url_fputws( L"\t\tBIGNUM! More at:\n", output ); + dump_object( output, cell.payload.integer.more ); + } + break; + case KEYTV: + dump_string_cell( output, L"Keyword", pointer ); + break; + case LAMBDATV: + url_fwprintf( output, L"\t\t\u03bb cell;\n\t\t args: " ); + print( output, cell.payload.lambda.args ); + url_fwprintf( output, L";\n\t\t\tbody: " ); + print( output, cell.payload.lambda.body ); + url_fputws( L"\n", output ); + break; + case NILTV: + break; + case NLAMBDATV: + url_fwprintf( output, L"\t\tn\u03bb cell; \n\t\targs: " ); + print( output, cell.payload.lambda.args ); + url_fwprintf( output, L";\n\t\t\tbody: " ); + print( output, cell.payload.lambda.body ); + url_fputws( L"\n", output ); + break; + case RATIOTV: + url_fwprintf( + output, L"\t\tRational cell: value %ld/%ld, count %u\n", + pointer2cell( cell.payload.ratio.dividend ).payload.integer.value, + pointer2cell( cell.payload.ratio.divisor ).payload.integer.value, + cell.count ); + break; + case READTV: + url_fputws( L"\t\tInput stream; metadata: ", output ); + print( output, cell.payload.stream.meta ); + url_fputws( L"\n", output ); + break; + case REALTV: + url_fwprintf( output, L"\t\tReal cell: value %Lf, count %u\n", + cell.payload.real.value, cell.count ); + break; + case STRINGTV: + dump_string_cell( output, L"String", pointer ); + break; + case SYMBOLTV: + dump_string_cell( output, L"Symbol", pointer ); + break; + case TRUETV: + break; + case VECTORPOINTTV: { + url_fwprintf( output, L"\t\tPointer to vector-space object at %p\n", + cell.payload.vectorp.address ); + struct vector_space_object *vso = cell.payload.vectorp.address; + url_fwprintf( output, + L"\t\tVector space object of type %4.4s (%d), payload size " + L"%d bytes\n", + &vso->header.tag.bytes, vso->header.tag.value, + vso->header.size ); - switch ( vso->header.tag.value ) { - case STACKFRAMETV: - dump_frame( output, pointer ); - break; - case HASHTV: - dump_map( output, pointer); - break; - } - } - break; - case WRITETV: - url_fputws( L"\t\tOutput stream; metadata: ", output ); - print( output, cell.payload.stream.meta ); - url_fputws( L"\n", output ); - break; - } + switch ( vso->header.tag.value ) { + case STACKFRAMETV: + dump_frame( output, pointer ); + break; + case HASHTV: + dump_map( output, pointer ); + break; + } + } break; + case WRITETV: + url_fputws( L"\t\tOutput stream; metadata: ", output ); + print( output, cell.payload.stream.meta ); + url_fputws( L"\n", output ); + break; + } } diff --git a/src/memory/hashmap.c b/src/memory/hashmap.c index 11a03f0..73d3905 100644 --- a/src/memory/hashmap.c +++ b/src/memory/hashmap.c @@ -12,6 +12,7 @@ #include "authorise.h" #include "debug.h" #include "intern.h" +#include "io/print.h" #include "memory/conspage.h" #include "memory/consspaceobject.h" #include "memory/hashmap.h" diff --git a/src/memory/vectorspace.c b/src/memory/vectorspace.c index b3e64c6..a6e292d 100644 --- a/src/memory/vectorspace.c +++ b/src/memory/vectorspace.c @@ -119,11 +119,11 @@ struct cons_pointer make_vso( char *tag, uint64_t payload_size ) { * object. Dangerous! */ void free_vso( struct cons_pointer pointer ) { - struct cons_space_object * cell = &pointer2cell( pointer); + struct cons_space_object cell = pointer2cell( pointer ); debug_printf( DEBUG_ALLOC, L"About to free vector-space object at 0x%lx\n", - cell->payload.vectorp.address ); - struct vector_space_object *vso = cell->payload.vectorp.address; + cell.payload.vectorp.address ); + struct vector_space_object *vso = cell.payload.vectorp.address; switch ( vso->header.tag.value ) { case HASHTV: @@ -134,7 +134,18 @@ void free_vso( struct cons_pointer pointer ) { break; } - free( (void *)cell->payload.vectorp.address ); +// free( (void *)cell.payload.vectorp.address ); debug_printf( DEBUG_ALLOC, L"Freed vector-space object at 0x%lx\n", - cell->payload.vectorp.address ); -} \ No newline at end of file + cell.payload.vectorp.address ); +} + +// bool check_vso_tag( struct cons_pointer pointer, char * tag) { +// bool result = false; + +// if (check_tag(pointer, VECTORPOINTTAG)) { +// struct vector_space_object * vso = pointer_to_vso(pointer); +// result = strncmp( vso->header.tag.bytes[0], tag, TAGLENGTH); +// } + +// return result; +// } diff --git a/src/ops/lispops.c b/src/ops/lispops.c index 3a972a5..0c495f9 100644 --- a/src/ops/lispops.c +++ b/src/ops/lispops.c @@ -854,26 +854,6 @@ lisp_equal( struct stack_frame *frame, struct cons_pointer frame_pointer, return equal( frame->arg[0], frame->arg[1] ) ? TRUE : NIL; } - -/** - * Resutn the current default input, or of `inputp` is false, output stream from - * this `env`ironment. - */ -struct cons_pointer get_default_stream( bool inputp, struct cons_pointer env ) { - struct cons_pointer result = NIL; - struct cons_pointer stream_name = - c_string_to_lisp_symbol( inputp ? L"*in*" : L"*out*" ); - - inc_ref( stream_name ); - - result = c_assoc( stream_name, env ); - - dec_ref( stream_name ); - - return result; -} - - /** * Function; read one complete lisp form and return it. If read-stream is specified and * is a read stream, then read from that stream, else the stream which is the value of @@ -965,6 +945,44 @@ struct cons_pointer lisp_reverse( struct stack_frame *frame, return c_reverse( frame->arg[0] ); } +/** + * Function: dump/inspect one complete lisp expression and return NIL. If + * write-stream is specified and is a write stream, then print to that stream, + * else the stream which is the value of + * `*out*` in the environment. + * + * * (inspect expr) + * * (inspect expr write-stream) + * + * @param frame my stack_frame. + * @param frame_pointer a pointer to my stack_frame. + * @param env my environment (from which the stream may be extracted). + * @return NIL. + */ +struct cons_pointer lisp_inspect( struct stack_frame *frame, + struct cons_pointer frame_pointer, + struct cons_pointer env ) { + debug_print( L"Entering lisp_inspect\n", DEBUG_IO ); + struct cons_pointer result = NIL; + struct cons_pointer out_stream = writep( frame->arg[1] ) + ? frame->arg[1] + : get_default_stream( false, env ); + URL_FILE *output; + + if ( writep( out_stream ) ) { + debug_print( L"lisp_inspect: setting output stream\n", DEBUG_IO ); + debug_dump_object( out_stream, DEBUG_IO ); + output = pointer2cell( out_stream ).payload.stream.stream; + } else { + output = file_to_url_file( stderr ); + } + + dump_object( output, frame->arg[0] ); + + debug_print( L"Leaving lisp_inspect", DEBUG_IO ); + + return result; +} /** * Function; print one complete lisp expression and return NIL. If write-stream is specified and @@ -976,8 +994,8 @@ struct cons_pointer lisp_reverse( struct stack_frame *frame, * * @param frame my stack_frame. * @param frame_pointer a pointer to my stack_frame. - * @param env my environment (ignored). - * @return the value of `expr`. + * @param env my environment (from which the stream may be extracted). + * @return NIL. */ struct cons_pointer lisp_print( struct stack_frame *frame, struct cons_pointer frame_pointer, @@ -1332,43 +1350,43 @@ struct cons_pointer lisp_source( struct stack_frame *frame, } -/** - * Function; print the internal representation of the object indicated by `frame->arg[0]` to the - * (optional, defaults to the value of `*out*` in the environment) stream indicated by `frame->arg[1]`. - * - * * (inspect expression) - * * (inspect expression ) - * - * @param frame my stack frame. - * @param frame_pointer a pointer to my stack_frame. - * @param env the environment. - * @return the value of the first argument - `expression`. - */ -struct cons_pointer lisp_inspect( struct stack_frame *frame, - struct cons_pointer frame_pointer, - struct cons_pointer env ) { - debug_print( L"Entering print\n", DEBUG_IO ); - URL_FILE *output; - struct cons_pointer out_stream = writep( frame->arg[1] ) ? - frame->arg[1] : get_default_stream( false, env ); +// /** +// * Function; print the internal representation of the object indicated by `frame->arg[0]` to the +// * (optional, defaults to the value of `*out*` in the environment) stream indicated by `frame->arg[1]`. +// * +// * * (inspect expression) +// * * (inspect expression ) +// * +// * @param frame my stack frame. +// * @param frame_pointer a pointer to my stack_frame. +// * @param env the environment. +// * @return the value of the first argument - `expression`. +// */ +// struct cons_pointer lisp_inspect( struct stack_frame *frame, +// struct cons_pointer frame_pointer, +// struct cons_pointer env ) { +// debug_print( L"Entering print\n", DEBUG_IO ); +// URL_FILE *output; +// struct cons_pointer out_stream = writep( frame->arg[1] ) ? +// frame->arg[1] : get_default_stream( false, env ); - if ( writep( out_stream ) ) { - debug_print( L"lisp_print: setting output stream\n", DEBUG_IO ); - debug_dump_object( out_stream, DEBUG_IO ); - output = pointer2cell( out_stream ).payload.stream.stream; - inc_ref( out_stream ); - } else { - output = file_to_url_file( stdout ); - } +// if ( writep( out_stream ) ) { +// debug_print( L"lisp_print: setting output stream\n", DEBUG_IO ); +// debug_dump_object( out_stream, DEBUG_IO ); +// output = pointer2cell( out_stream ).payload.stream.stream; +// inc_ref( out_stream ); +// } else { +// output = file_to_url_file( stdout ); +// } - dump_object( output, frame->arg[0] ); - url_fputws( L"\n", output ); +// dump_object( output, frame->arg[0] ); +// url_fputws( L"\n", output ); - if ( writep( out_stream ) ) { - dec_ref( out_stream ); - } else { - free( output ); - } +// if ( writep( out_stream ) ) { +// dec_ref( out_stream ); +// } else { +// free( output ); +// } - return frame->arg[0]; -} +// return frame->arg[0]; +// } diff --git a/src/ops/lispops.h b/src/ops/lispops.h index 4669493..014df2e 100644 --- a/src/ops/lispops.h +++ b/src/ops/lispops.h @@ -114,6 +114,9 @@ struct cons_pointer lisp_quote( struct stack_frame *frame, /* * functions */ +struct cons_pointer lisp_assoc( struct stack_frame *frame, + struct cons_pointer frame_pointer, + struct cons_pointer env ); struct cons_pointer lisp_cons( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ); @@ -123,9 +126,9 @@ struct cons_pointer lisp_car( struct stack_frame *frame, struct cons_pointer lisp_cdr( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ); -struct cons_pointer lisp_assoc( struct stack_frame *frame, - struct cons_pointer frame_pointer, - struct cons_pointer env ); +struct cons_pointer lisp_inspect( struct stack_frame *frame, + struct cons_pointer frame_pointer, + struct cons_pointer env ); struct cons_pointer lisp_eq( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ); @@ -199,8 +202,4 @@ struct cons_pointer lisp_source( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ); -struct cons_pointer lisp_inspect( struct stack_frame *frame, - struct cons_pointer frame_pointer, - struct cons_pointer env ); - #endif From 93d4bd14a081783c5ff082579ac6fddb159ccc74 Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Tue, 17 Aug 2021 16:09:00 +0100 Subject: [PATCH 11/28] Generally, changed working with tags as strings to as values. This seems both cheaper and safer; what's not to like? --- Makefile | 5 ++-- src/arith/integer.c | 3 +-- src/arith/ratio.c | 2 +- src/arith/real.c | 2 +- src/io/read.c | 12 ++++----- src/memory/conspage.c | 6 ++--- src/memory/conspage.h | 2 +- src/memory/consspaceobject.c | 40 +++++++++++++-------------- src/memory/consspaceobject.h | 52 ++++++++++++++++++------------------ src/memory/hashmap.c | 13 +++++---- src/memory/stack.c | 2 +- src/memory/vectorspace.c | 12 ++++----- src/memory/vectorspace.h | 8 +++--- src/ops/lispops.c | 2 +- src/time/psse_time.c | 2 +- unit-tests/lambda.sh | 2 +- unit-tests/map.sh | 10 +++---- 17 files changed, 87 insertions(+), 88 deletions(-) diff --git a/Makefile b/Makefile index c4c4ef3..d8e6e81 100644 --- a/Makefile +++ b/Makefile @@ -17,11 +17,12 @@ INDENT_FLAGS := -nbad -bap -nbc -br -brf -brs -c33 -cd33 -ncdb -ce -ci4 -cli4 \ CPPFLAGS ?= $(INC_FLAGS) -MMD -MP -g -DDEBUG LDFLAGS := -lm -lcurl +DEBUGFLAGS := -g3 all: $(TARGET) $(TARGET): $(OBJS) Makefile - $(CC) $(LDFLAGS) $(OBJS) -o $@ $(LDFLAGS) $(LOADLIBES) $(LDLIBS) + $(CC) $(DEBUGFLAGS) $(LDFLAGS) $(OBJS) -o $@ $(LDFLAGS) $(LOADLIBES) $(LDLIBS) doc: $(SRCS) Makefile Doxyfile doxygen @@ -38,7 +39,7 @@ test: $(OBJS) $(TESTS) Makefile .PHONY: clean clean: - $(RM) $(TARGET) $(OBJS) $(DEPS) $(SRC_DIRS)/*~ $(SRC_DIRS)/*/*~ *~ + $(RM) $(TARGET) $(OBJS) $(DEPS) $(SRC_DIRS)/*~ $(SRC_DIRS)/*/*~ *~ core repl: $(TARGET) -p 2> psse.log diff --git a/src/arith/integer.c b/src/arith/integer.c index e02d30e..5f47532 100644 --- a/src/arith/integer.c +++ b/src/arith/integer.c @@ -46,11 +46,10 @@ struct cons_pointer make_integer( int64_t value, struct cons_pointer more ) { debug_print( L"Entering make_integer\n", DEBUG_ALLOC ); if ( integerp( more ) || nilp( more ) ) { - result = allocate_cell( INTEGERTAG ); + result = allocate_cell( INTEGERTV ); struct cons_space_object *cell = &pointer2cell( result ); cell->payload.integer.value = value; cell->payload.integer.more = more; - } debug_print( L"make_integer: returning\n", DEBUG_ALLOC ); diff --git a/src/arith/ratio.c b/src/arith/ratio.c index 8976e38..f4c8056 100644 --- a/src/arith/ratio.c +++ b/src/arith/ratio.c @@ -315,7 +315,7 @@ struct cons_pointer make_ratio( struct cons_pointer dividend, if ( integerp( dividend ) && integerp( divisor ) ) { inc_ref( dividend ); inc_ref( divisor ); - result = allocate_cell( RATIOTAG ); + result = allocate_cell( RATIOTV ); struct cons_space_object *cell = &pointer2cell( result ); cell->payload.ratio.dividend = dividend; cell->payload.ratio.divisor = divisor; diff --git a/src/arith/real.c b/src/arith/real.c index 84ba899..a59a125 100644 --- a/src/arith/real.c +++ b/src/arith/real.c @@ -19,7 +19,7 @@ * @return a real number cell wrapping this value. */ struct cons_pointer make_real( long double value ) { - struct cons_pointer result = allocate_cell( REALTAG ); + struct cons_pointer result = allocate_cell( REALTV ); struct cons_space_object *cell = &pointer2cell( result ); cell->payload.real.value = value; diff --git a/src/io/read.c b/src/io/read.c index ede44ad..2395cbc 100644 --- a/src/io/read.c +++ b/src/io/read.c @@ -49,7 +49,7 @@ struct cons_pointer read_map( struct stack_frame *frame, struct cons_pointer frame_pointer, URL_FILE * input, wint_t initial ); struct cons_pointer read_string( URL_FILE * input, wint_t initial ); -struct cons_pointer read_symbol_or_key( URL_FILE * input, char *tag, +struct cons_pointer read_symbol_or_key( URL_FILE * input, uint32_t tag, wint_t initial ); /** @@ -119,7 +119,7 @@ struct cons_pointer read_continuation( struct stack_frame *frame, read_number( frame, frame_pointer, input, c, false ); } else { - result = read_symbol_or_key( input, SYMBOLTAG, c ); + result = read_symbol_or_key( input, SYMBOLTV, c ); } } break; @@ -139,20 +139,20 @@ struct cons_pointer read_continuation( struct stack_frame *frame, debug_print( L"read_continuation: dotted pair; read cdr ", DEBUG_IO); } else { - read_symbol_or_key( input, SYMBOLTAG, c ); + read_symbol_or_key( input, SYMBOLTV, c ); } } break; case ':': result = - read_symbol_or_key( input, KEYTAG, url_fgetwc( input ) ); + read_symbol_or_key( input, KEYTV, url_fgetwc( input ) ); break; default: if ( iswdigit( c ) ) { result = read_number( frame, frame_pointer, input, c, false ); } else if ( iswprint( c ) ) { - result = read_symbol_or_key( input, SYMBOLTAG, c ); + result = read_symbol_or_key( input, SYMBOLTV, c ); } else { result = throw_exception( make_cons( c_string_to_lisp_string @@ -386,7 +386,7 @@ struct cons_pointer read_string( URL_FILE * input, wint_t initial ) { return result; } -struct cons_pointer read_symbol_or_key( URL_FILE * input, char *tag, +struct cons_pointer read_symbol_or_key( URL_FILE * input, uint32_t tag, wint_t initial ) { struct cons_pointer cdr = NIL; struct cons_pointer result; diff --git a/src/memory/conspage.c b/src/memory/conspage.c index c9c224d..0b4bf7d 100644 --- a/src/memory/conspage.c +++ b/src/memory/conspage.c @@ -140,7 +140,7 @@ void free_cell( struct cons_pointer pointer ) { debug_printf( DEBUG_ALLOC, L"Freeing cell " ); debug_dump_object( pointer, DEBUG_ALLOC ); - if ( !check_tag( pointer, FREETAG ) ) { + if ( !check_tag( pointer, FREETV ) ) { if ( cell->count == 0 ) { switch ( cell->tag.value ) { case CONSTV: @@ -209,7 +209,7 @@ void free_cell( struct cons_pointer pointer ) { * return an exception. Which, as we cannot create such an exception when * cons space is exhausted, means we must construct it at init time. */ -struct cons_pointer allocate_cell( char *tag ) { +struct cons_pointer allocate_cell( uint32_t tag ) { struct cons_pointer result = freelist; @@ -222,7 +222,7 @@ struct cons_pointer allocate_cell( char *tag ) { if ( strncmp( &cell->tag.bytes[0], FREETAG, TAGLENGTH ) == 0 ) { freelist = cell->payload.free.cdr; - strncpy( &cell->tag.bytes[0], tag, TAGLENGTH ); + cell->tag.value = tag; cell->count = 0; cell->payload.cons.car = NIL; diff --git a/src/memory/conspage.h b/src/memory/conspage.h index 9eab748..260794e 100644 --- a/src/memory/conspage.h +++ b/src/memory/conspage.h @@ -55,7 +55,7 @@ extern struct cons_page *conspages[NCONSPAGES]; void free_cell( struct cons_pointer pointer ); -struct cons_pointer allocate_cell( char *tag ); +struct cons_pointer allocate_cell( uint32_t tag ); void initialise_cons_pages( ); diff --git a/src/memory/consspaceobject.c b/src/memory/consspaceobject.c index 9e956f4..32c777f 100644 --- a/src/memory/consspaceobject.c +++ b/src/memory/consspaceobject.c @@ -28,22 +28,22 @@ #include "vectorspace.h" /** - * True if the tag on the cell at this `pointer` is this `tag`, or, if the tag - * of the cell is `VECP`, if the tag of the vectorspace object indicated by the - * cell is this `tag`, else false. + * True if the value of the tag on the cell at this `pointer` is this `value`, + * or, if the tag of the cell is `VECP`, if the value of the tag of the + * vectorspace object indicated by the cell is this `value`, else false. */ -bool check_tag( struct cons_pointer pointer, char *tag ) { +bool check_tag( struct cons_pointer pointer, uint32_t value ) { bool result = false; + struct cons_space_object cell = pointer2cell( pointer ); - - result = strncmp( &cell.tag.bytes[0], tag, TAGLENGTH ) == 0; + result = cell.tag.value == value; if ( result == false ) { if ( cell.tag.value == VECTORPOINTTV ) { struct vector_space_object *vec = pointer_to_vso( pointer ); if ( vec != NULL ) { - result = strncmp( &(vec->header.tag.bytes[0]), tag, TAGLENGTH ) == 0; + result = vec->header.tag.value == value; } } } @@ -177,7 +177,7 @@ struct cons_pointer make_cons( struct cons_pointer car, struct cons_pointer cdr ) { struct cons_pointer pointer = NIL; - pointer = allocate_cell( CONSTAG ); + pointer = allocate_cell( CONSTV ); struct cons_space_object *cell = &pointer2cell( pointer ); @@ -197,7 +197,7 @@ struct cons_pointer make_cons( struct cons_pointer car, struct cons_pointer make_exception( struct cons_pointer message, struct cons_pointer frame_pointer ) { struct cons_pointer result = NIL; - struct cons_pointer pointer = allocate_cell( EXCEPTIONTAG ); + struct cons_pointer pointer = allocate_cell( EXCEPTIONTV ); struct cons_space_object *cell = &pointer2cell( pointer ); inc_ref( message ); @@ -218,7 +218,7 @@ struct cons_pointer make_function( struct cons_pointer meta, struct cons_pointer ( *executable ) ( struct stack_frame *, struct cons_pointer, struct cons_pointer ) ) { - struct cons_pointer pointer = allocate_cell( FUNCTIONTAG ); + struct cons_pointer pointer = allocate_cell( FUNCTIONTV ); struct cons_space_object *cell = &pointer2cell( pointer ); inc_ref( meta ); @@ -233,7 +233,7 @@ make_function( struct cons_pointer meta, struct cons_pointer ( *executable ) */ struct cons_pointer make_lambda( struct cons_pointer args, struct cons_pointer body ) { - struct cons_pointer pointer = allocate_cell( LAMBDATAG ); + struct cons_pointer pointer = allocate_cell( LAMBDATV ); struct cons_space_object *cell = &pointer2cell( pointer ); inc_ref( pointer ); /* this is a hack; I don't know why it's necessary to do this, but if I don't the cell gets freed */ @@ -252,7 +252,7 @@ struct cons_pointer make_lambda( struct cons_pointer args, */ struct cons_pointer make_nlambda( struct cons_pointer args, struct cons_pointer body ) { - struct cons_pointer pointer = allocate_cell( NLAMBDATAG ); + struct cons_pointer pointer = allocate_cell( NLAMBDATV ); inc_ref( pointer ); /* this is a hack; I don't know why it's necessary to do this, but if I don't the cell gets freed */ @@ -309,10 +309,10 @@ uint32_t calculate_hash(wint_t c, struct cons_pointer ptr) * pointer to next is NIL. */ struct cons_pointer -make_string_like_thing( wint_t c, struct cons_pointer tail, char *tag ) { +make_string_like_thing( wint_t c, struct cons_pointer tail, uint32_t tag ) { struct cons_pointer pointer = NIL; - if ( check_tag( tail, tag ) || check_tag( tail, NILTAG ) ) { + if ( check_tag( tail, tag ) || check_tag( tail, NILTV ) ) { pointer = allocate_cell( tag ); struct cons_space_object *cell = &pointer2cell( pointer ); @@ -344,7 +344,7 @@ make_string_like_thing( wint_t c, struct cons_pointer tail, char *tag ) { * @param tail the string which is being built. */ struct cons_pointer make_string( wint_t c, struct cons_pointer tail ) { - return make_string_like_thing( c, tail, STRINGTAG ); + return make_string_like_thing( c, tail, STRINGTV ); } /** @@ -356,10 +356,10 @@ struct cons_pointer make_string( wint_t c, struct cons_pointer tail ) { * @param tag the tag to use: expected to be "SYMB" or "KEYW" */ struct cons_pointer make_symbol_or_key( wint_t c, struct cons_pointer tail, - char *tag ) { + uint32_t tag ) { struct cons_pointer result = make_string_like_thing( c, tail, tag ); - if ( strncmp( tag, KEYTAG, 4 ) == 0 ) { + if ( tag == KEYTV ) { struct cons_pointer r = internedp( result, oblist ); if ( nilp( r ) ) { @@ -379,7 +379,7 @@ struct cons_pointer make_special( struct cons_pointer meta, struct cons_pointer ( *executable ) ( struct stack_frame * frame, struct cons_pointer, struct cons_pointer env ) ) { - struct cons_pointer pointer = allocate_cell( SPECIALTAG ); + struct cons_pointer pointer = allocate_cell( SPECIALTV ); struct cons_space_object *cell = &pointer2cell( pointer ); inc_ref( meta ); @@ -397,7 +397,7 @@ make_special( struct cons_pointer meta, struct cons_pointer ( *executable ) */ struct cons_pointer make_read_stream( URL_FILE * input, struct cons_pointer metadata ) { - struct cons_pointer pointer = allocate_cell( READTAG ); + struct cons_pointer pointer = allocate_cell( READTV ); struct cons_space_object *cell = &pointer2cell( pointer ); cell->payload.stream.stream = input; @@ -414,7 +414,7 @@ struct cons_pointer make_read_stream( URL_FILE * input, */ struct cons_pointer make_write_stream( URL_FILE * output, struct cons_pointer metadata ) { - struct cons_pointer pointer = allocate_cell( WRITETAG ); + struct cons_pointer pointer = allocate_cell( WRITETV ); struct cons_space_object *cell = &pointer2cell( pointer ); cell->payload.stream.stream = output; diff --git a/src/memory/consspaceobject.h b/src/memory/consspaceobject.h index 98a5a24..0efa0a6 100644 --- a/src/memory/consspaceobject.h +++ b/src/memory/consspaceobject.h @@ -276,114 +276,114 @@ * true if `conspoint` points to the special cell NIL, else false * (there should only be one of these so it's slightly redundant). */ -#define nilp(conspoint) (check_tag(conspoint,NILTAG)) +#define nilp(conspoint) (check_tag(conspoint,NILTV)) /** * true if `conspoint` points to a cons cell, else false */ -#define consp(conspoint) (check_tag(conspoint,CONSTAG)) +#define consp(conspoint) (check_tag(conspoint,CONSTV)) /** * true if `conspoint` points to an exception, else false */ -#define exceptionp(conspoint) (check_tag(conspoint,EXCEPTIONTAG)) +#define exceptionp(conspoint) (check_tag(conspoint,EXCEPTIONTV)) /** * true if `conspoint` points to a function cell, else false */ -#define functionp(conspoint) (check_tag(conspoint,FUNCTIONTAG)) +#define functionp(conspoint) (check_tag(conspoint,FUNCTIONTV)) /** * true if `conspoint` points to a keyword, else false */ -#define keywordp(conspoint) (check_tag(conspoint,KEYTAG)) +#define keywordp(conspoint) (check_tag(conspoint,KEYTV)) /** * true if `conspoint` points to a Lambda binding cell, else false */ -#define lambdap(conspoint) (check_tag(conspoint,LAMBDATAG)) +#define lambdap(conspoint) (check_tag(conspoint,LAMBDATV)) /** * true if `conspoint` points to a loop exit exception, else false. */ -#define loopexitp(conspoint) (check_tag(conspoint,LOOPXTAG)) +#define loopexitp(conspoint) (check_tag(conspoint,LOOPXTV)) /** * true if `conspoint` points to a special form cell, else false */ -#define specialp(conspoint) (check_tag(conspoint,SPECIALTAG)) +#define specialp(conspoint) (check_tag(conspoint,SPECIALTV)) /** * true if `conspoint` points to a string cell, else false */ -#define stringp(conspoint) (check_tag(conspoint,STRINGTAG)) +#define stringp(conspoint) (check_tag(conspoint,STRINGTV)) /** * true if `conspoint` points to a symbol cell, else false */ -#define symbolp(conspoint) (check_tag(conspoint,SYMBOLTAG)) +#define symbolp(conspoint) (check_tag(conspoint,SYMBOLTV)) /** * true if `conspoint` points to an integer cell, else false */ -#define integerp(conspoint) (check_tag(conspoint,INTEGERTAG)) +#define integerp(conspoint) (check_tag(conspoint,INTEGERTV)) /** * true if `conspoint` points to a rational number cell, else false */ -#define ratiop(conspoint) (check_tag(conspoint,RATIOTAG)) +#define ratiop(conspoint) (check_tag(conspoint,RATIOTV)) /** * true if `conspoint` points to a read stream cell, else false */ -#define readp(conspoint) (check_tag(conspoint,READTAG)) +#define readp(conspoint) (check_tag(conspoint,READTV)) /** * true if `conspoint` points to a real number cell, else false */ -#define realp(conspoint) (check_tag(conspoint,REALTAG)) +#define realp(conspoint) (check_tag(conspoint,REALTV)) /** * true if `conspoint` points to some sort of a number cell, * else false */ -#define numberp(conspoint) (check_tag(conspoint,INTEGERTAG)||check_tag(conspoint,RATIOTAG)||check_tag(conspoint,REALTAG)) +#define numberp(conspoint) (check_tag(conspoint,INTEGERTV)||check_tag(conspoint,RATIOTV)||check_tag(conspoint,REALTV)) /** * true if `conspoint` points to a sequence (list, string or, later, vector), * else false. */ -#define sequencep(conspoint) (check_tag(conspoint,CONSTAG)||check_tag(conspoint,STRINGTAG)||check_tag(conspoint,SYMBOLTAG)) +#define sequencep(conspoint) (check_tag(conspoint,CONSTV)||check_tag(conspoint,STRINGTV)||check_tag(conspoint,SYMBOLTV)) /** * true if `conspoint` points to a vector pointer, else false. */ -#define vectorpointp(conspoint) (check_tag(conspoint,VECTORPOINTTAG)) +#define vectorpointp(conspoint) (check_tag(conspoint,VECTORPOINTTV)) /** * true if `conspoint` points to a write stream cell, else false. */ -#define writep(conspoint) (check_tag(conspoint,WRITETAG)) +#define writep(conspoint) (check_tag(conspoint,WRITETV)) -#define streamp(conspoint) (check_tag(conspoint,READTAG)||check_tag(conspoint,WRITETAG)) +#define streamp(conspoint) (check_tag(conspoint,READTV)||check_tag(conspoint,WRITETV)) /** * true if `conspoint` points to a true cell, else false * (there should only be one of these so it's slightly redundant). * Also note that anything that is not NIL is truthy. */ -#define tp(conspoint) (check_tag(conspoint,TRUETAG)) +#define tp(conspoint) (check_tag(conspoint,TRUETV)) /** * true if `conspoint` points to a time cell, else false. */ -#define timep(conspoint) (check_tag(conspoint,TIMETAG)) +#define timep(conspoint) (check_tag(conspoint,TIMETV)) /** * true if `conspoint` points to something that is truthy, i.e. * anything but NIL. */ -#define truep(conspoint) (!check_tag(conspoint,NILTAG)) +#define truep(conspoint) (!check_tag(conspoint,NILTV)) /** * An indirect pointer to a cons cell @@ -673,7 +673,7 @@ struct cons_space_object { } payload; }; -bool check_tag( struct cons_pointer pointer, char *tag ); +bool check_tag( struct cons_pointer pointer, uint32_t value ); struct cons_pointer inc_ref( struct cons_pointer pointer ); @@ -716,11 +716,11 @@ struct cons_pointer make_special( struct cons_pointer src, struct cons_pointer make_string( wint_t c, struct cons_pointer tail ); struct cons_pointer make_symbol_or_key( wint_t c, struct cons_pointer tail, - char *tag ); + uint32_t tag ); -#define make_symbol(c, t) (make_symbol_or_key( c, t, SYMBOLTAG)) +#define make_symbol(c, t) (make_symbol_or_key( c, t, SYMBOLTV)) -#define make_keyword(c, t) (make_symbol_or_key( c, t, KEYTAG)) +#define make_keyword(c, t) (make_symbol_or_key( c, t, KEYTV)) struct cons_pointer make_read_stream( URL_FILE * input, struct cons_pointer metadata ); diff --git a/src/memory/hashmap.c b/src/memory/hashmap.c index 73d3905..ae15461 100644 --- a/src/memory/hashmap.c +++ b/src/memory/hashmap.c @@ -78,17 +78,16 @@ void free_hashmap( struct cons_pointer pointer ) { if ( hashmapp( pointer ) ) { struct vector_space_object *vso = cell->payload.vectorp.address; - struct hashmap_payload payload = vso->payload.hashmap; - dec_ref( payload.hash_fn ); - dec_ref( payload.write_acl ); + dec_ref( vso->payload.hashmap.hash_fn ); + dec_ref( vso->payload.hashmap.write_acl ); - for ( int i = 0; i < payload.n_buckets; i++ ) { - if ( !nilp( payload.buckets[i] ) ) { + for ( int i = 0; i < vso->payload.hashmap.n_buckets; i++ ) { + if ( !nilp( vso->payload.hashmap.buckets[i] ) ) { debug_printf( DEBUG_ALLOC, L"Decrementing bucket [%d] of hashmap at 0x%lx\n", i, cell->payload.vectorp.address ); - dec_ref( payload.buckets[i] ); + dec_ref( vso->payload.hashmap.buckets[i] ); } } } else { @@ -114,7 +113,7 @@ struct cons_pointer make_hashmap( uint32_t n_buckets, struct cons_pointer hash_fn, struct cons_pointer write_acl ) { struct cons_pointer result = - make_vso( HASHTAG, ( sizeof( struct cons_pointer ) * ( n_buckets + 1 ) ) + + make_vso( HASHTV, ( sizeof( struct cons_pointer ) * ( n_buckets + 1 ) ) + ( sizeof( uint32_t ) * 2 ) ); struct hashmap_payload *payload = diff --git a/src/memory/stack.c b/src/memory/stack.c index e26bd0e..8b0e610 100644 --- a/src/memory/stack.c +++ b/src/memory/stack.c @@ -75,7 +75,7 @@ struct stack_frame *get_stack_frame( struct cons_pointer pointer ) { struct cons_pointer make_empty_frame( struct cons_pointer previous ) { debug_print( L"Entering make_empty_frame\n", DEBUG_ALLOC ); struct cons_pointer result = - make_vso( STACKFRAMETAG, sizeof( struct stack_frame ) ); + make_vso( STACKFRAMETV, sizeof( struct stack_frame ) ); debug_dump_object( result, DEBUG_ALLOC ); diff --git a/src/memory/vectorspace.c b/src/memory/vectorspace.c index a6e292d..02fd239 100644 --- a/src/memory/vectorspace.c +++ b/src/memory/vectorspace.c @@ -33,15 +33,15 @@ * * @address the address of the vector_space_object to point to. * @tag the vector-space tag of the particular type of vector-space object, - * NOT `VECTORPOINTTAG`. + * NOT `VECTORPOINTTV`. * * @return a cons_pointer to the object, or NIL if the object could not be * allocated due to memory exhaustion. */ struct cons_pointer make_vec_pointer( struct vector_space_object *address, - char *tag ) { + uint32_t tag ) { debug_print( L"Entered make_vec_pointer\n", DEBUG_ALLOC ); - struct cons_pointer pointer = allocate_cell( VECTORPOINTTAG ); + struct cons_pointer pointer = allocate_cell( VECTORPOINTTV ); struct cons_space_object *cell = &pointer2cell( pointer ); debug_printf( DEBUG_ALLOC, @@ -49,7 +49,7 @@ struct cons_pointer make_vec_pointer( struct vector_space_object *address, address ); cell->payload.vectorp.address = address; - strncpy( &cell->payload.vectorp.tag.bytes[0], tag, TAGLENGTH ); + cell->payload.vectorp.tag.value = tag; debug_printf( DEBUG_ALLOC, L"make_vec_pointer: all good, returning pointer to %p\n", @@ -71,7 +71,7 @@ struct cons_pointer make_vec_pointer( struct vector_space_object *address, * @return a cons_pointer to the object, or NIL if the object could not be * allocated due to memory exhaustion. */ -struct cons_pointer make_vso( char *tag, uint64_t payload_size ) { +struct cons_pointer make_vso( uint32_t tag, uint64_t payload_size ) { debug_print( L"Entered make_vso\n", DEBUG_ALLOC ); struct cons_pointer result = NIL; int64_t total_size = sizeof( struct vector_space_header ) + payload_size; @@ -87,7 +87,7 @@ struct cons_pointer make_vso( char *tag, uint64_t payload_size ) { debug_printf( DEBUG_ALLOC, L"make_vso: about to write tag '%s' into vso at %p\n", tag, vso ); - strncpy( &vso->header.tag.bytes[0], tag, TAGLENGTH ); + vso->header.tag.value = tag; result = make_vec_pointer( vso, tag ); debug_dump_object( result, DEBUG_ALLOC ); vso->header.vecp = result; diff --git a/src/memory/vectorspace.h b/src/memory/vectorspace.h index 2c163e8..2eea84d 100644 --- a/src/memory/vectorspace.h +++ b/src/memory/vectorspace.h @@ -29,7 +29,7 @@ #define HASHTAG "HASH" #define HASHTV 1213415752 -#define hashmapp(conspoint)((check_tag(conspoint,HASHTAG))) +#define hashmapp(conspoint)((check_tag(conspoint,HASHTV))) /* * a namespace (i.e. a binding of names to values, implemented as a hashmap) @@ -39,7 +39,7 @@ #define NAMESPACETAG "NMSP" #define NAMESPACETV 1347636558 -#define namespacep(conspoint)(check_tag(conspoint,NAMESPACETAG)) +#define namespacep(conspoint)(check_tag(conspoint,NAMESPACETV)) /* * a vector of cons pointers. @@ -47,7 +47,7 @@ #define VECTORTAG "VECT" #define VECTORTV 1413694806 -#define vectorp(conspoint)(check_tag(conspoint,VECTORTAG)) +#define vectorp(conspoint)(check_tag(conspoint,VECTORTV)) /** * given a pointer to a vector space object, return the object. @@ -59,7 +59,7 @@ */ #define vso_get_vecp(vso)((((vector_space_object)vso)->header.vecp)) -struct cons_pointer make_vso( char *tag, uint64_t payload_size ); +struct cons_pointer make_vso( uint32_t tag, uint64_t payload_size ); void free_vso(struct cons_pointer pointer); diff --git a/src/ops/lispops.c b/src/ops/lispops.c index 0c495f9..474784d 100644 --- a/src/ops/lispops.c +++ b/src/ops/lispops.c @@ -920,7 +920,7 @@ struct cons_pointer c_reverse( struct cons_pointer arg ) { case SYMBOLTV: result = make_symbol_or_key( o.payload.string.character, result, - SYMBOLTAG ); + SYMBOLTV ); break; } } diff --git a/src/time/psse_time.c b/src/time/psse_time.c index 76f52a9..e37e522 100644 --- a/src/time/psse_time.c +++ b/src/time/psse_time.c @@ -56,7 +56,7 @@ unsigned __int128 unix_time_to_lisp_time( time_t t) { } struct cons_pointer make_time( struct cons_pointer integer_or_nil) { - struct cons_pointer pointer = allocate_cell( TIMETAG ); + struct cons_pointer pointer = allocate_cell( TIMETV ); struct cons_space_object *cell = &pointer2cell( pointer ); if (integerp(integer_or_nil)) { diff --git a/unit-tests/lambda.sh b/unit-tests/lambda.sh index b7f1707..9695e6c 100755 --- a/unit-tests/lambda.sh +++ b/unit-tests/lambda.sh @@ -1,6 +1,6 @@ #!/bin/bash -expected='(lambda (l) l) (1 2 3 4 5 6 7 8 9 10)' +expected=' (1 2 3 4 5 6 7 8 9 10)' output=`target/psse 2>/dev/null < Date: Tue, 17 Aug 2021 16:37:04 +0100 Subject: [PATCH 12/28] Restandardised formatting. --- src/arith/integer.c | 85 +- src/arith/integer.h | 18 +- src/arith/peano.c | 49 +- src/arith/peano.h | 2 +- src/arith/ratio.c | 80 +- src/arith/ratio.h | 2 +- src/authorise.c | 8 +- src/authorise.h | 5 +- src/init.c | 57 +- src/io/fopen.c | 2 +- src/io/io.c | 36 +- src/io/print.c | 88 +- src/io/read.c | 83 +- src/memory/conspage.c | 2 +- src/memory/consspaceobject.c | 142 ++- src/memory/consspaceobject.h | 2 +- src/memory/dump.c | 207 ++--- src/memory/hashmap.c | 369 ++++---- src/memory/hashmap.h | 6 +- src/memory/lookup3.c | 1594 ++++++++++++++++++++-------------- src/memory/lookup3.h | 5 +- src/memory/vectorspace.c | 28 +- src/memory/vectorspace.h | 24 +- src/ops/equal.c | 169 ++-- src/ops/intern.c | 45 +- src/ops/lispops.c | 295 +++---- src/ops/lispops.h | 4 +- src/time/psse_time.c | 51 +- src/time/psse_time.h | 7 +- 29 files changed, 1861 insertions(+), 1604 deletions(-) diff --git a/src/arith/integer.c b/src/arith/integer.c index 5f47532..db486d2 100644 --- a/src/arith/integer.c +++ b/src/arith/integer.c @@ -218,18 +218,19 @@ struct cons_pointer base_partial( int depth ) { /** * destructively modify this `partial` by appending this `digit`. */ -struct cons_pointer append_digit( struct cons_pointer partial, struct cons_pointer digit) { +struct cons_pointer append_digit( struct cons_pointer partial, + struct cons_pointer digit ) { struct cons_pointer c = partial; struct cons_pointer result = partial; - if (nilp( partial)) { + if ( nilp( partial ) ) { result = digit; } else { - while ( !nilp( pointer2cell(c).payload.integer.more)) { - c = pointer2cell(c).payload.integer.more; + while ( !nilp( pointer2cell( c ).payload.integer.more ) ) { + c = pointer2cell( c ).payload.integer.more; } - (&pointer2cell(c))->payload.integer.more = digit; + ( &pointer2cell( c ) )->payload.integer.more = digit; } return result; } @@ -248,8 +249,8 @@ struct cons_pointer append_digit( struct cons_pointer partial, struct cons_point * @param b an integer. */ struct cons_pointer multiply_integers( struct cons_pointer a, - struct cons_pointer b ) { - struct cons_pointer result = make_integer( 0, NIL); + struct cons_pointer b ) { + struct cons_pointer result = make_integer( 0, NIL ); bool neg = is_negative( a ) != is_negative( b ); bool is_first_b = true; int i = 0; @@ -264,7 +265,7 @@ struct cons_pointer multiply_integers( struct cons_pointer a, /* for each digit in a, starting with the least significant (ai) */ for ( struct cons_pointer ai = a; !nilp( ai ); - ai = pointer2cell(ai).payload.integer.more) { + ai = pointer2cell( ai ).payload.integer.more ) { /* set carry to 0 */ __int128_t carry = 0; @@ -274,41 +275,41 @@ struct cons_pointer multiply_integers( struct cons_pointer a, /* for each digit in b, starting with the least significant (bj) */ for ( struct cons_pointer bj = b; !nilp( bj ); - bj = pointer2cell(bj).payload.integer.more) { + bj = pointer2cell( bj ).payload.integer.more ) { debug_printf( DEBUG_ARITH, - L"multiply_integers: a[i] = %Ld, b[j] = %Ld, i = %d\n", - pointer2cell(ai).payload.integer.value, - pointer2cell(bj).payload.integer.value, i); + L"multiply_integers: a[i] = %Ld, b[j] = %Ld, i = %d\n", + pointer2cell( ai ).payload.integer.value, + pointer2cell( bj ).payload.integer.value, i ); /* multiply ai with bj and add the carry, resulting in a * value xj which may exceed one digit */ - __int128_t xj = pointer2cell(ai).payload.integer.value * - pointer2cell(bj).payload.integer.value; + __int128_t xj = pointer2cell( ai ).payload.integer.value * + pointer2cell( bj ).payload.integer.value; xj += carry; /* if xj exceeds one digit, break it into the digit dj and * the carry */ carry = xj >> 60; - struct cons_pointer dj = make_integer( xj & MAX_INTEGER, NIL); + struct cons_pointer dj = make_integer( xj & MAX_INTEGER, NIL ); /* destructively modify ri by appending dj */ - ri = append_digit( ri, dj); - } /* end for bj */ + ri = append_digit( ri, dj ); + } /* end for bj */ /* if carry is not equal to zero, append it as a final digit * to ri */ - if (carry != 0) { - ri = append_digit( ri, make_integer( carry, NIL)); + if ( carry != 0 ) { + ri = append_digit( ri, make_integer( carry, NIL ) ); } /* add ri to result */ - result = add_integers( result, ri); + result = add_integers( result, ri ); debug_print( L"multiply_integers: result is ", DEBUG_ARITH ); debug_print_object( result, DEBUG_ARITH ); debug_println( DEBUG_ARITH ); - } /* end for ai */ + } /* end for ai */ } debug_print( L"multiply_integers returning: ", DEBUG_ARITH ); @@ -342,13 +343,16 @@ struct cons_pointer integer_to_string_add_digit( int digit, int digits, * to be looking to the next. H'mmmm. */ struct cons_pointer integer_to_string( struct cons_pointer int_pointer, - int base ) { + int base ) { struct cons_pointer result = NIL; if ( integerp( int_pointer ) ) { - struct cons_pointer next = pointer2cell( int_pointer ).payload.integer.more; - __int128_t accumulator = llabs( pointer2cell( int_pointer ).payload.integer.value ); - bool is_negative = pointer2cell( int_pointer ).payload.integer.value < 0; + struct cons_pointer next = + pointer2cell( int_pointer ).payload.integer.more; + __int128_t accumulator = + llabs( pointer2cell( int_pointer ).payload.integer.value ); + bool is_negative = + pointer2cell( int_pointer ).payload.integer.value < 0; int digits = 0; if ( accumulator == 0 && nilp( next ) ) { @@ -356,13 +360,14 @@ struct cons_pointer integer_to_string( struct cons_pointer int_pointer, } else { while ( accumulator > 0 || !nilp( next ) ) { if ( accumulator < MAX_INTEGER && !nilp( next ) ) { - accumulator += (pointer2cell(next).payload.integer.value << 60); - next = pointer2cell(next).payload.integer.more; + accumulator += + ( pointer2cell( next ).payload.integer.value << 60 ); + next = pointer2cell( next ).payload.integer.more; } int offset = ( int ) ( accumulator % base ); debug_printf( DEBUG_IO, - L"integer_to_string: digit is %ld, hexadecimal is %c, accumulator is: ", - offset, hex_digits[offset] ); + L"integer_to_string: digit is %ld, hexadecimal is %c, accumulator is: ", + offset, hex_digits[offset] ); debug_print_128bit( accumulator, DEBUG_IO ); debug_print( L"; result is: ", DEBUG_IO ); debug_print_object( result, DEBUG_IO ); @@ -374,7 +379,7 @@ struct cons_pointer integer_to_string( struct cons_pointer int_pointer, } if ( stringp( result ) - && pointer2cell( result ).payload.string.character == L',' ) { + && pointer2cell( result ).payload.string.character == L',' ) { /* if the number of digits in the string is divisible by 3, there will be * an unwanted comma on the front. */ result = pointer2cell( result ).payload.string.cdr; @@ -393,14 +398,15 @@ struct cons_pointer integer_to_string( struct cons_pointer int_pointer, /** * true if a and be are both integers whose value is the same value. */ -bool equal_integer_integer(struct cons_pointer a, struct cons_pointer b) { +bool equal_integer_integer( struct cons_pointer a, struct cons_pointer b ) { bool result = false; - if (integerp(a) && integerp(b)){ + if ( integerp( a ) && integerp( b ) ) { struct cons_space_object *cell_a = &pointer2cell( a ); struct cons_space_object *cell_b = &pointer2cell( b ); - result = cell_a->payload.integer.value == cell_b->payload.integer.value; + result = + cell_a->payload.integer.value == cell_b->payload.integer.value; } return result; @@ -410,17 +416,16 @@ bool equal_integer_integer(struct cons_pointer a, struct cons_pointer b) { * true if `a` is an integer, and `b` is a real number whose value is the * value of that integer. */ -bool equal_integer_real(struct cons_pointer a, struct cons_pointer b) { +bool equal_integer_real( struct cons_pointer a, struct cons_pointer b ) { bool result = false; - if (integerp(a) && realp(b)) - { - long double bv = pointer2cell(b).payload.real.value; + if ( integerp( a ) && realp( b ) ) { + long double bv = pointer2cell( b ).payload.real.value; - if (floor(bv) == bv) { - result = pointer2cell(a).payload.integer.value == (int64_t)bv; + if ( floor( bv ) == bv ) { + result = pointer2cell( a ).payload.integer.value == ( int64_t ) bv; } } return result; -} \ No newline at end of file +} diff --git a/src/arith/integer.h b/src/arith/integer.h index 4ce58d5..09a7a83 100644 --- a/src/arith/integer.h +++ b/src/arith/integer.h @@ -14,19 +14,19 @@ #include #include -struct cons_pointer make_integer(int64_t value, struct cons_pointer more); +struct cons_pointer make_integer( int64_t value, struct cons_pointer more ); -struct cons_pointer add_integers(struct cons_pointer a, - struct cons_pointer b); +struct cons_pointer add_integers( struct cons_pointer a, + struct cons_pointer b ); -struct cons_pointer multiply_integers(struct cons_pointer a, - struct cons_pointer b); +struct cons_pointer multiply_integers( struct cons_pointer a, + struct cons_pointer b ); -struct cons_pointer integer_to_string(struct cons_pointer int_pointer, - int base); +struct cons_pointer integer_to_string( struct cons_pointer int_pointer, + int base ); -bool equal_integer_integer(struct cons_pointer a, struct cons_pointer b); +bool equal_integer_integer( struct cons_pointer a, struct cons_pointer b ); -bool equal_integer_real(struct cons_pointer a, struct cons_pointer b); +bool equal_integer_real( struct cons_pointer a, struct cons_pointer b ); #endif diff --git a/src/arith/peano.c b/src/arith/peano.c index 8fe63fb..5589f1f 100644 --- a/src/arith/peano.c +++ b/src/arith/peano.c @@ -247,8 +247,7 @@ struct cons_pointer add_2( struct stack_frame *frame, result = add_integers( arg1, arg2 ); break; case RATIOTV: - result = - add_integer_ratio( arg1, arg2 ); + result = add_integer_ratio( arg1, arg2 ); break; case REALTV: result = @@ -268,8 +267,7 @@ struct cons_pointer add_2( struct stack_frame *frame, result = arg2; break; case INTEGERTV: - result = - add_integer_ratio( arg2, arg1 ); + result = add_integer_ratio( arg2, arg1 ); break; case RATIOTV: result = add_ratio_ratio( arg1, arg2 ); @@ -380,9 +378,7 @@ struct cons_pointer multiply_2( struct stack_frame *frame, result = multiply_integers( arg1, arg2 ); break; case RATIOTV: - result = - multiply_integer_ratio( arg1, - arg2 ); + result = multiply_integer_ratio( arg1, arg2 ); break; case REALTV: result = @@ -405,13 +401,10 @@ struct cons_pointer multiply_2( struct stack_frame *frame, result = arg2; break; case INTEGERTV: - result = - multiply_integer_ratio( arg2, - arg1 ); + result = multiply_integer_ratio( arg2, arg1 ); break; case RATIOTV: - result = - multiply_ratio_ratio( arg1, arg2 ); + result = multiply_ratio_ratio( arg1, arg2 ); break; case REALTV: result = @@ -564,20 +557,18 @@ struct cons_pointer subtract_2( struct stack_frame *frame, result = arg2; break; case INTEGERTV:{ - struct cons_pointer i = - negative( arg2 ); + struct cons_pointer i = negative( arg2 ); inc_ref( i ); result = add_integers( arg1, i ); dec_ref( i ); } break; case RATIOTV:{ - struct cons_pointer tmp = - make_ratio( arg1, - make_integer( 1, NIL ) ); + struct cons_pointer tmp = make_ratio( arg1, + make_integer( 1, + NIL ) ); inc_ref( tmp ); - result = - subtract_ratio_ratio( tmp, arg2 ); + result = subtract_ratio_ratio( tmp, arg2 ); dec_ref( tmp ); } break; @@ -599,12 +590,11 @@ struct cons_pointer subtract_2( struct stack_frame *frame, result = arg2; break; case INTEGERTV:{ - struct cons_pointer tmp = - make_ratio( arg2, - make_integer( 1, NIL ) ); + struct cons_pointer tmp = make_ratio( arg2, + make_integer( 1, + NIL ) ); inc_ref( tmp ); - result = - subtract_ratio_ratio( arg1, tmp ); + result = subtract_ratio_ratio( arg1, tmp ); dec_ref( tmp ); } break; @@ -696,9 +686,7 @@ struct cons_pointer lisp_divide( struct struct cons_pointer ratio = make_ratio( frame->arg[0], one ); inc_ref( ratio ); - result = - divide_ratio_ratio( ratio, - frame->arg[1] ); + result = divide_ratio_ratio( ratio, frame->arg[1] ); dec_ref( ratio ); } break; @@ -725,17 +713,14 @@ struct cons_pointer lisp_divide( struct struct cons_pointer ratio = make_ratio( frame->arg[1], one ); inc_ref( ratio ); - result = - divide_ratio_ratio( frame->arg[0], - ratio ); + result = divide_ratio_ratio( frame->arg[0], ratio ); dec_ref( ratio ); dec_ref( one ); } break; case RATIOTV: result = - divide_ratio_ratio( frame->arg[0], - frame->arg[1] ); + divide_ratio_ratio( frame->arg[0], frame->arg[1] ); break; case REALTV: result = diff --git a/src/arith/peano.h b/src/arith/peano.h index 9bcd9e4..3076391 100644 --- a/src/arith/peano.h +++ b/src/arith/peano.h @@ -27,7 +27,7 @@ struct cons_pointer absolute( struct cons_pointer arg ); long double to_long_double( struct cons_pointer arg ); -int64_t to_long_int( struct cons_pointer arg ) ; +int64_t to_long_int( struct cons_pointer arg ); struct cons_pointer lisp_absolute( struct stack_frame *frame, struct cons_pointer frame_pointer, struct diff --git a/src/arith/ratio.c b/src/arith/ratio.c index f4c8056..8100ec2 100644 --- a/src/arith/ratio.c +++ b/src/arith/ratio.c @@ -43,42 +43,36 @@ int64_t least_common_multiple( int64_t m, int64_t n ) { return m / greatest_common_divisor( m, n ) * n; } -struct cons_pointer simplify_ratio( struct cons_pointer pointer) { +struct cons_pointer simplify_ratio( struct cons_pointer pointer ) { struct cons_pointer result = pointer; - struct cons_space_object cell = pointer2cell(pointer); - struct cons_space_object dividend = pointer2cell(cell.payload.ratio.dividend); - struct cons_space_object divisor = pointer2cell(cell.payload.ratio.divisor); + struct cons_space_object cell = pointer2cell( pointer ); + struct cons_space_object dividend = + pointer2cell( cell.payload.ratio.dividend ); + struct cons_space_object divisor = + pointer2cell( cell.payload.ratio.divisor ); - if (divisor.payload.integer.value == 1) - { - result = pointer2cell(pointer).payload.ratio.dividend; - } - else - { - if (ratiop(pointer)) - { + if ( divisor.payload.integer.value == 1 ) { + result = pointer2cell( pointer ).payload.ratio.dividend; + } else { + if ( ratiop( pointer ) ) { int64_t ddrv = dividend.payload.integer.value, - drrv = divisor.payload.integer.value, - gcd = greatest_common_divisor(ddrv, drrv); + drrv = divisor.payload.integer.value, + gcd = greatest_common_divisor( ddrv, drrv ); - if (gcd > 1) - { - if (drrv / gcd == 1) - { - result = make_integer(ddrv / gcd, NIL); - } - else - { + if ( gcd > 1 ) { + if ( drrv / gcd == 1 ) { + result = make_integer( ddrv / gcd, NIL ); + } else { result = - make_ratio(make_integer(ddrv / gcd, NIL), - make_integer(drrv / gcd, NIL)); + make_ratio( make_integer( ddrv / gcd, NIL ), + make_integer( drrv / gcd, NIL ) ); } } } } return result; - + } @@ -181,8 +175,7 @@ struct cons_pointer add_integer_ratio( struct cons_pointer intarg, ( L"Shouldn't happen: bad arg to add_integer_ratio" ), make_cons( intarg, make_cons( ratarg, - NIL ) ) ), - NIL ); + NIL ) ) ), NIL ); } return result; @@ -196,11 +189,10 @@ struct cons_pointer add_integer_ratio( struct cons_pointer intarg, */ struct cons_pointer divide_ratio_ratio( struct cons_pointer arg1, struct cons_pointer arg2 ) { - // TODO: this now has to work if `arg1` is an integer - struct cons_pointer i = make_ratio( pointer2cell( arg2 ).payload. - ratio.divisor, - pointer2cell( arg2 ).payload. - ratio.dividend ), result = + // TODO: this now has to work if `arg1` is an integer + struct cons_pointer i = + make_ratio( pointer2cell( arg2 ).payload.ratio.divisor, + pointer2cell( arg2 ).payload.ratio.dividend ), result = multiply_ratio_ratio( arg1, i ); dec_ref( i ); @@ -217,7 +209,7 @@ struct cons_pointer divide_ratio_ratio( struct cons_pointer arg1, struct cons_pointer multiply_ratio_ratio( struct cons_pointer arg1, struct cons_pointer arg2 ) { - // TODO: this now has to work if arg1 is an integer + // TODO: this now has to work if arg1 is an integer struct cons_pointer result; debug_print( L"multiply_ratio_ratio( arg1 = ", DEBUG_ARITH ); @@ -294,7 +286,7 @@ struct cons_pointer multiply_integer_ratio( struct cons_pointer intarg, */ struct cons_pointer subtract_ratio_ratio( struct cons_pointer arg1, struct cons_pointer arg2 ) { - struct cons_pointer i = negative( arg2), + struct cons_pointer i = negative( arg2 ), result = add_ratio_ratio( arg1, i ); dec_ref( i ); @@ -333,20 +325,18 @@ struct cons_pointer make_ratio( struct cons_pointer dividend, /** * True if a and be are identical ratios, else false. */ -bool equal_ratio_ratio(struct cons_pointer a, struct cons_pointer b) -{ +bool equal_ratio_ratio( struct cons_pointer a, struct cons_pointer b ) { bool result = false; - if (ratiop(a) && ratiop(b)) - { - struct cons_space_object *cell_a = &pointer2cell(a); - struct cons_space_object *cell_b = &pointer2cell(b); + if ( ratiop( a ) && ratiop( b ) ) { + struct cons_space_object *cell_a = &pointer2cell( a ); + struct cons_space_object *cell_b = &pointer2cell( b ); - result = equal_integer_integer(cell_a->payload.ratio.dividend, - cell_b->payload.ratio.dividend) && - equal_integer_integer(cell_a->payload.ratio.divisor, - cell_b->payload.ratio.divisor); + result = equal_integer_integer( cell_a->payload.ratio.dividend, + cell_b->payload.ratio.dividend ) && + equal_integer_integer( cell_a->payload.ratio.divisor, + cell_b->payload.ratio.divisor ); } return result; -} \ No newline at end of file +} diff --git a/src/arith/ratio.h b/src/arith/ratio.h index d440530..9068bfb 100644 --- a/src/arith/ratio.h +++ b/src/arith/ratio.h @@ -34,6 +34,6 @@ struct cons_pointer subtract_ratio_ratio( struct cons_pointer arg1, struct cons_pointer make_ratio( struct cons_pointer dividend, struct cons_pointer divisor ); -bool equal_ratio_ratio(struct cons_pointer a, struct cons_pointer b); +bool equal_ratio_ratio( struct cons_pointer a, struct cons_pointer b ); #endif diff --git a/src/authorise.c b/src/authorise.c index 5574db9..afd730d 100644 --- a/src/authorise.c +++ b/src/authorise.c @@ -15,10 +15,10 @@ * TODO: does nothing, yet. What it should do is access a magic value in the * runtime environment and check that it is identical to something on this `acl` */ -struct cons_pointer authorised(struct cons_pointer target, struct cons_pointer acl) { - if (nilp(acl)) { - acl = pointer2cell(target).access; +struct cons_pointer authorised( struct cons_pointer target, + struct cons_pointer acl ) { + if ( nilp( acl ) ) { + acl = pointer2cell( target ).access; } return TRUE; } - diff --git a/src/authorise.h b/src/authorise.h index c67977d..6c55b32 100644 --- a/src/authorise.h +++ b/src/authorise.h @@ -10,6 +10,7 @@ #ifndef __psse_authorise_h #define __psse_authorise_h -struct cons_pointer authorised(struct cons_pointer target, struct cons_pointer acl); +struct cons_pointer authorised( struct cons_pointer target, + struct cons_pointer acl ); -#endif \ No newline at end of file +#endif diff --git a/src/init.c b/src/init.c index 4126783..ca48b9d 100644 --- a/src/init.c +++ b/src/init.c @@ -84,8 +84,9 @@ void bind_value( wchar_t *name, struct cons_pointer value ) { dec_ref( n ); } -void print_banner() { - fwprintf(stdout, L"Post-Scarcity Software Environment version %s\n\n", VERSION); +void print_banner( ) { + fwprintf( stdout, L"Post-Scarcity Software Environment version %s\n\n", + VERSION ); } /** @@ -93,22 +94,24 @@ void print_banner() { * * @stream the stream to print to. */ -void print_options(FILE* stream) { - fwprintf(stream, L"Expected options are:\n"); - fwprintf(stream, L"\t-d\tDump memory to standard out at end of run (copious!);\n"); - fwprintf(stream, L"\t-h\tPrint this message and exit;\n"); - fwprintf(stream, L"\t-p\tShow a prompt (default is no prompt);\n"); - fwprintf(stream, L"\t-v LEVEL\n\t\tSet verbosity to the specified level (0...512)\n"); - fwprintf(stream, L"\t\tWhere bits are interpreted as follows:\n"); - fwprintf(stream, L"\t\t1\tALLOC;\n"); - fwprintf(stream, L"\t\t2\tARITH;\n"); - fwprintf(stream, L"\t\t4\tBIND;\n"); - fwprintf(stream, L"\t\t8\tBOOTSTRAP;\n"); - fwprintf(stream, L"\t\t16\tEVAL;\n"); - fwprintf(stream, L"\t\t32\tINPUT/OUTPUT;\n"); - fwprintf(stream, L"\t\t64\tLAMBDA;\n"); - fwprintf(stream, L"\t\t128\tREPL;\n"); - fwprintf(stream, L"\t\t256\tSTACK.\n"); +void print_options( FILE * stream ) { + fwprintf( stream, L"Expected options are:\n" ); + fwprintf( stream, + L"\t-d\tDump memory to standard out at end of run (copious!);\n" ); + fwprintf( stream, L"\t-h\tPrint this message and exit;\n" ); + fwprintf( stream, L"\t-p\tShow a prompt (default is no prompt);\n" ); + fwprintf( stream, + L"\t-v LEVEL\n\t\tSet verbosity to the specified level (0...512)\n" ); + fwprintf( stream, L"\t\tWhere bits are interpreted as follows:\n" ); + fwprintf( stream, L"\t\t1\tALLOC;\n" ); + fwprintf( stream, L"\t\t2\tARITH;\n" ); + fwprintf( stream, L"\t\t4\tBIND;\n" ); + fwprintf( stream, L"\t\t8\tBOOTSTRAP;\n" ); + fwprintf( stream, L"\t\t16\tEVAL;\n" ); + fwprintf( stream, L"\t\t32\tINPUT/OUTPUT;\n" ); + fwprintf( stream, L"\t\t64\tLAMBDA;\n" ); + fwprintf( stream, L"\t\t128\tREPL;\n" ); + fwprintf( stream, L"\t\t256\tSTACK.\n" ); } /** @@ -132,8 +135,8 @@ int main( int argc, char *argv[] ) { dump_at_end = true; break; case 'h': - print_banner(); - print_options(stdout); + print_banner( ); + print_options( stdout ); exit( 0 ); break; case 'p': @@ -144,14 +147,14 @@ int main( int argc, char *argv[] ) { break; default: fwprintf( stderr, L"Unexpected option %c\n", option ); - print_options(stderr); + print_options( stderr ); exit( 1 ); break; } } if ( show_prompt ) { - print_banner(); + print_banner( ); } debug_print( L"About to initialise cons pages\n", DEBUG_BOOTSTRAP ); @@ -225,10 +228,10 @@ int main( int argc, char *argv[] ) { bind_function( L"equal", &lisp_equal ); bind_function( L"eval", &lisp_eval ); bind_function( L"exception", &lisp_exception ); - bind_function( L"get-hash", &lisp_get_hash); - bind_function(L"hashmap", lisp_make_hashmap); + bind_function( L"get-hash", &lisp_get_hash ); + bind_function( L"hashmap", lisp_make_hashmap ); bind_function( L"inspect", &lisp_inspect ); - bind_function( L"keys", &lisp_keys); + bind_function( L"keys", &lisp_keys ); bind_function( L"meta", &lisp_metadata ); bind_function( L"metadata", &lisp_metadata ); bind_function( L"multiply", &lisp_multiply ); @@ -237,8 +240,8 @@ int main( int argc, char *argv[] ) { bind_function( L"open", &lisp_open ); bind_function( L"print", &lisp_print ); bind_function( L"progn", &lisp_progn ); - bind_function( L"put", lisp_hashmap_put); - bind_function( L"put-all", &lisp_hashmap_put_all); + bind_function( L"put", lisp_hashmap_put ); + bind_function( L"put-all", &lisp_hashmap_put_all ); bind_function( L"read", &lisp_read ); bind_function( L"read-char", &lisp_read_char ); bind_function( L"repl", &lisp_repl ); diff --git a/src/io/fopen.c b/src/io/fopen.c index d3ece5c..3a66806 100644 --- a/src/io/fopen.c +++ b/src/io/fopen.c @@ -213,7 +213,7 @@ URL_FILE *url_fopen( const char *url, const char *operation ) { file->handle.file = fopen( url, operation ); if ( file->handle.file ) { file->type = CFTYPE_FILE; /* marked as file */ - } else if ( index_of(':', url ) > -1 ) { + } else if ( index_of( ':', url ) > -1 ) { file->type = CFTYPE_CURL; /* marked as URL */ file->handle.curl = curl_easy_init( ); diff --git a/src/io/io.c b/src/io/io.c index 9976373..f621539 100644 --- a/src/io/io.c +++ b/src/io/io.c @@ -265,7 +265,7 @@ struct cons_pointer add_meta_integer( struct cons_pointer meta, wchar_t *key, struct cons_pointer add_meta_string( struct cons_pointer meta, wchar_t *key, char *value ) { - value = trim( value); + value = trim( value ); wchar_t buffer[strlen( value ) + 1]; mbstowcs( buffer, value, strlen( value ) + 1 ); @@ -280,9 +280,8 @@ struct cons_pointer add_meta_time( struct cons_pointer meta, wchar_t *key, char datestring[256]; strftime( datestring, - sizeof( datestring ), - nl_langinfo( D_T_FMT ), - localtime( value ) ); + sizeof( datestring ), + nl_langinfo( D_T_FMT ), localtime( value ) ); return add_meta_string( meta, key, datestring ); } @@ -391,7 +390,7 @@ void collect_meta( struct cons_pointer stream, char *url ) { } /* this is destructive change before the cell is released into the - * wild, and consequently permissible, just. */ + * wild, and consequently permissible, just. */ cell->payload.stream.meta = meta; } @@ -441,20 +440,23 @@ lisp_open( struct stack_frame *frame, struct cons_pointer frame_pointer, URL_FILE *stream = url_fopen( url, "r" ); debug_printf( DEBUG_IO, - L"lisp_open: stream @ %ld, stream type = %d, stream handle = %ld\n", - (long int) &stream, (int)stream->type, (long int)stream->handle.file); + L"lisp_open: stream @ %ld, stream type = %d, stream handle = %ld\n", + ( long int ) &stream, ( int ) stream->type, + ( long int ) stream->handle.file ); - switch (stream->type) { + switch ( stream->type ) { case CFTYPE_NONE: - return make_exception( - c_string_to_lisp_string( L"Could not open stream"), - frame_pointer); + return + make_exception( c_string_to_lisp_string + ( L"Could not open stream" ), + frame_pointer ); break; case CFTYPE_FILE: - if (stream->handle.file == NULL) { - return make_exception( - c_string_to_lisp_string( L"Could not open file"), - frame_pointer); + if ( stream->handle.file == NULL ) { + return + make_exception( c_string_to_lisp_string + ( L"Could not open file" ), + frame_pointer ); } break; case CFTYPE_CURL: @@ -501,8 +503,8 @@ lisp_read_char( struct stack_frame *frame, struct cons_pointer frame_pointer, if ( readp( frame->arg[0] ) ) { result = make_string( url_fgetwc - ( pointer2cell( frame->arg[0] ).payload. - stream.stream ), NIL ); + ( pointer2cell( frame->arg[0] ).payload.stream. + stream ), NIL ); } return result; diff --git a/src/io/print.c b/src/io/print.c index 3f33252..64d7b37 100644 --- a/src/io/print.c +++ b/src/io/print.c @@ -88,38 +88,38 @@ void print_list( URL_FILE * output, struct cons_pointer pointer ) { url_fputws( L")", output ); } -void print_map( URL_FILE *output, struct cons_pointer map ) { - if ( hashmapp( map ) ) { - struct vector_space_object *vso = pointer_to_vso( map ); +void print_map( URL_FILE * output, struct cons_pointer map ) { + if ( hashmapp( map ) ) { + struct vector_space_object *vso = pointer_to_vso( map ); - url_fputwc( btowc( '{' ), output ); + url_fputwc( btowc( '{' ), output ); - for ( struct cons_pointer ks = hashmap_keys( map ); !nilp( ks ); - ks = c_cdr( ks ) ) { - struct cons_pointer key = c_car( ks); - print( output, key ); - url_fputwc( btowc( ' ' ), output ); - print( output, hashmap_get( map, key ) ); + for ( struct cons_pointer ks = hashmap_keys( map ); !nilp( ks ); + ks = c_cdr( ks ) ) { + struct cons_pointer key = c_car( ks ); + print( output, key ); + url_fputwc( btowc( ' ' ), output ); + print( output, hashmap_get( map, key ) ); - if ( !nilp( c_cdr( ks ) ) ) { - url_fputws( L", ", output ); - } + if ( !nilp( c_cdr( ks ) ) ) { + url_fputws( L", ", output ); + } + } + + url_fputwc( btowc( '}' ), output ); } - - url_fputwc( btowc( '}' ), output ); - } } -void print_vso( URL_FILE * output, struct cons_pointer pointer) { - struct vector_space_object *vso = pointer_to_vso(pointer); - switch ( vso->header.tag.value) { +void print_vso( URL_FILE * output, struct cons_pointer pointer ) { + struct vector_space_object *vso = pointer_to_vso( pointer ); + switch ( vso->header.tag.value ) { case HASHTV: - print_map( output, pointer); + print_map( output, pointer ); break; - // \todo: others. + // \todo: others. default: - fwprintf( stderr, L"Unrecognised vector-space type '%d'\n", - vso->header.tag.value ); + fwprintf( stderr, L"Unrecognised vector-space type '%d'\n", + vso->header.tag.value ); } } @@ -130,14 +130,14 @@ void print_128bit( URL_FILE * output, __int128_t n ) { if ( n == 0 ) { fwprintf( stderr, L"0" ); } else { - char str[40] = { 0 }; // log10(1 << 128) + '\0' + char str[40] = { 0 }; // log10(1 << 128) + '\0' char *s = str + sizeof( str ) - 1; // start at the end while ( n != 0 ) { if ( s == str ) - return; // never happens + return; // never happens *--s = "0123456789"[n % 10]; // save last digit - n /= 10; // drop it + n /= 10; // drop it } url_fwprintf( output, L"%s", s ); } @@ -165,9 +165,9 @@ struct cons_pointer print( URL_FILE * output, struct cons_pointer pointer ) { dump_stack_trace( output, pointer ); break; case FUNCTIONTV: - url_fputws( L"', output); + url_fputws( L"', output ); break; case INTEGERTV:{ struct cons_pointer s = integer_to_string( pointer, 10 ); @@ -181,7 +181,7 @@ struct cons_pointer print( URL_FILE * output, struct cons_pointer pointer ) { print_string_contents( output, pointer ); break; case LAMBDATV:{ - url_fputws( L"', output); + url_fputwc( L'>', output ); } break; case NILTV: url_fwprintf( output, L"nil" ); break; case NLAMBDATV:{ - url_fputws( L"', output); + url_fputwc( L'>', output ); } break; case RATIOTV: @@ -218,8 +218,8 @@ struct cons_pointer print( URL_FILE * output, struct cons_pointer pointer ) { break; case READTV: url_fwprintf( output, L"', output); + print( output, cell.payload.stream.meta ); + url_fputwc( L'>', output ); break; case REALTV: /* \todo using the C heap is a bad plan because it will fragment. @@ -245,26 +245,26 @@ struct cons_pointer print( URL_FILE * output, struct cons_pointer pointer ) { break; case SPECIALTV: url_fwprintf( output, L"', output); + print( output, cell.payload.special.meta ); + url_fputwc( L'>', output ); break; case TIMETV: url_fwprintf( output, L"', output); + print_string( output, time_to_string( pointer ) ); + url_fputws( L"; ", output ); + print_128bit( output, pointer2cell( pointer ).payload.time.value ); + url_fputwc( L'>', output ); break; case TRUETV: url_fwprintf( output, L"t" ); break; case VECTORPOINTTV: - print_vso( output, pointer); + print_vso( output, pointer ); break; case WRITETV: url_fwprintf( output, L"', output); + print( output, cell.payload.stream.meta ); + url_fputwc( L'>', output ); break; default: fwprintf( stderr, diff --git a/src/io/read.c b/src/io/read.c index 2395cbc..9c87932 100644 --- a/src/io/read.c +++ b/src/io/read.c @@ -46,8 +46,8 @@ struct cons_pointer read_list( struct stack_frame *frame, struct cons_pointer frame_pointer, URL_FILE * input, wint_t initial ); struct cons_pointer read_map( struct stack_frame *frame, - struct cons_pointer frame_pointer, - URL_FILE * input, wint_t initial ); + struct cons_pointer frame_pointer, + URL_FILE * input, wint_t initial ); struct cons_pointer read_string( URL_FILE * input, wint_t initial ); struct cons_pointer read_symbol_or_key( URL_FILE * input, uint32_t tag, wint_t initial ); @@ -106,7 +106,7 @@ struct cons_pointer read_continuation( struct stack_frame *frame, break; case '{': result = read_map( frame, frame_pointer, input, - url_fgetwc( input ) ); + url_fgetwc( input ) ); break; case '"': result = read_string( input, url_fgetwc( input ) ); @@ -134,10 +134,12 @@ struct cons_pointer read_continuation( struct stack_frame *frame, } else if ( iswblank( next ) ) { /* dotted pair. \todo this isn't right, we * really need to backtrack up a level. */ - result = read_continuation( frame, frame_pointer, input, + result = + read_continuation( frame, frame_pointer, input, url_fgetwc( input ) ); - debug_print( L"read_continuation: dotted pair; read cdr ", - DEBUG_IO); + debug_print + ( L"read_continuation: dotted pair; read cdr ", + DEBUG_IO ); } else { read_symbol_or_key( input, SYMBOLTV, c ); } @@ -284,37 +286,34 @@ struct cons_pointer read_number( struct stack_frame *frame, * left parenthesis. */ struct cons_pointer read_list( struct stack_frame *frame, - struct cons_pointer frame_pointer, - URL_FILE * input, wint_t initial ) { + struct cons_pointer frame_pointer, + URL_FILE * input, wint_t initial ) { struct cons_pointer result = NIL; wint_t c; if ( initial != ')' ) { debug_printf( DEBUG_IO, - L"read_list starting '%C' (%d)\n", initial, initial ); + L"read_list starting '%C' (%d)\n", initial, initial ); struct cons_pointer car = read_continuation( frame, frame_pointer, input, - initial ); + initial ); /* skip whitespace */ - for (c = url_fgetwc( input ); - iswblank( c ) || iswcntrl( c ); - c = url_fgetwc( input )); + for ( c = url_fgetwc( input ); + iswblank( c ) || iswcntrl( c ); c = url_fgetwc( input ) ); - if ( c == L'.') { + if ( c == L'.' ) { /* might be a dotted pair; indeed, if we rule out numbers with * initial periods, it must be a dotted pair. \todo Ought to check, * howerver, that there's only one form after the period. */ result = make_cons( car, - c_car( read_list( frame, - frame_pointer, - input, - url_fgetwc( input ) ) ) ); + c_car( read_list( frame, + frame_pointer, + input, url_fgetwc( input ) ) ) ); } else { result = - make_cons( car, - read_list( frame, frame_pointer, input, c ) ); + make_cons( car, read_list( frame, frame_pointer, input, c ) ); } } else { debug_print( L"End of list detected\n", DEBUG_IO ); @@ -325,35 +324,35 @@ struct cons_pointer read_list( struct stack_frame *frame, struct cons_pointer read_map( struct stack_frame *frame, struct cons_pointer frame_pointer, - URL_FILE *input, wint_t initial ) { - // set write ACL to true whilst creating to prevent GC churn - struct cons_pointer result = make_hashmap( DFLT_HASHMAP_BUCKETS, NIL, TRUE ); - wint_t c = initial; + URL_FILE * input, wint_t initial ) { + // set write ACL to true whilst creating to prevent GC churn + struct cons_pointer result = + make_hashmap( DFLT_HASHMAP_BUCKETS, NIL, TRUE ); + wint_t c = initial; - while ( c != L'}' ) { - struct cons_pointer key = - read_continuation( frame, frame_pointer, input, c ); + while ( c != L'}' ) { + struct cons_pointer key = + read_continuation( frame, frame_pointer, input, c ); - /* skip whitespace */ - for ( c = url_fgetwc( input ); iswblank( c ) || iswcntrl( c ); - c = url_fgetwc( input ) ) - ; + /* skip whitespace */ + for ( c = url_fgetwc( input ); iswblank( c ) || iswcntrl( c ); + c = url_fgetwc( input ) ); - struct cons_pointer value = - read_continuation( frame, frame_pointer, input, c ); + struct cons_pointer value = + read_continuation( frame, frame_pointer, input, c ); - /* skip commaa and whitespace at this point. */ - for ( c = url_fgetwc( input ); c == L',' || iswblank( c ) || iswcntrl( c ); - c = url_fgetwc( input ) ) - ; + /* skip commaa and whitespace at this point. */ + for ( c = url_fgetwc( input ); + c == L',' || iswblank( c ) || iswcntrl( c ); + c = url_fgetwc( input ) ); - result = hashmap_put( result, key, value ); - } + result = hashmap_put( result, key, value ); + } - // default write ACL for maps should be NIL. - pointer_to_vso( result )->payload.hashmap.write_acl = NIL; + // default write ACL for maps should be NIL. + pointer_to_vso( result )->payload.hashmap.write_acl = NIL; - return result; + return result; } /** diff --git a/src/memory/conspage.c b/src/memory/conspage.c index 0b4bf7d..d8d54f9 100644 --- a/src/memory/conspage.c +++ b/src/memory/conspage.c @@ -179,7 +179,7 @@ void free_cell( struct cons_pointer pointer ) { dec_ref( cell->payload.string.cdr ); break; case VECTORPOINTTV: - free_vso( pointer); + free_vso( pointer ); break; } diff --git a/src/memory/consspaceobject.c b/src/memory/consspaceobject.c index 32c777f..5b04699 100644 --- a/src/memory/consspaceobject.c +++ b/src/memory/consspaceobject.c @@ -33,22 +33,22 @@ * vectorspace object indicated by the cell is this `value`, else false. */ bool check_tag( struct cons_pointer pointer, uint32_t value ) { - bool result = false; + bool result = false; - struct cons_space_object cell = pointer2cell( pointer ); - result = cell.tag.value == value; + struct cons_space_object cell = pointer2cell( pointer ); + result = cell.tag.value == value; - if ( result == false ) { - if ( cell.tag.value == VECTORPOINTTV ) { - struct vector_space_object *vec = pointer_to_vso( pointer ); + if ( result == false ) { + if ( cell.tag.value == VECTORPOINTTV ) { + struct vector_space_object *vec = pointer_to_vso( pointer ); - if ( vec != NULL ) { - result = vec->header.tag.value == value; - } + if ( vec != NULL ) { + result = vec->header.tag.value == value; + } + } } - } - return result; + return result; } /** @@ -99,22 +99,24 @@ struct cons_pointer dec_ref( struct cons_pointer pointer ) { * @return As a Lisp string, the tag of the object which is at that pointer. */ struct cons_pointer c_type( struct cons_pointer pointer ) { - struct cons_pointer result = NIL; - struct cons_space_object cell = pointer2cell( pointer ); + struct cons_pointer result = NIL; + struct cons_space_object cell = pointer2cell( pointer ); - if ( strncmp( (char *)&cell.tag.bytes, VECTORPOINTTAG, TAGLENGTH ) == 0 ) { - struct vector_space_object *vec = pointer_to_vso( pointer ); + if ( strncmp( ( char * ) &cell.tag.bytes, VECTORPOINTTAG, TAGLENGTH ) == + 0 ) { + struct vector_space_object *vec = pointer_to_vso( pointer ); - for ( int i = TAGLENGTH - 1; i >= 0; i-- ) { - result = make_string( (wchar_t)vec->header.tag.bytes[i], result ); + for ( int i = TAGLENGTH - 1; i >= 0; i-- ) { + result = + make_string( ( wchar_t ) vec->header.tag.bytes[i], result ); + } + } else { + for ( int i = TAGLENGTH - 1; i >= 0; i-- ) { + result = make_string( ( wchar_t ) cell.tag.bytes[i], result ); + } } - } else { - for ( int i = TAGLENGTH - 1; i >= 0; i-- ) { - result = make_string( (wchar_t)cell.tag.bytes[i], result ); - } - } - return result; + return result; } /** @@ -122,13 +124,13 @@ struct cons_pointer c_type( struct cons_pointer pointer ) { * authorised to read it, does not error but returns nil. */ struct cons_pointer c_car( struct cons_pointer arg ) { - struct cons_pointer result = NIL; + struct cons_pointer result = NIL; - if ( truep( authorised( arg, NIL ) ) && consp( arg ) ) { - result = pointer2cell( arg ).payload.cons.car; - } + if ( truep( authorised( arg, NIL ) ) && consp( arg ) ) { + result = pointer2cell( arg ).payload.cons.car; + } - return result; + return result; } /** @@ -136,34 +138,34 @@ struct cons_pointer c_car( struct cons_pointer arg ) { * not authorised to read it,does not error but returns nil. */ struct cons_pointer c_cdr( struct cons_pointer arg ) { - struct cons_pointer result = NIL; + struct cons_pointer result = NIL; - if ( truep( authorised( arg, NIL ) ) ) { - struct cons_space_object *cell = &pointer2cell( arg ); + if ( truep( authorised( arg, NIL ) ) ) { + struct cons_space_object *cell = &pointer2cell( arg ); - switch ( cell->tag.value ) { - case CONSTV: - result = cell->payload.cons.cdr; - break; - case KEYTV: - case STRINGTV: - case SYMBOLTV: - result = cell->payload.string.cdr; - break; + switch ( cell->tag.value ) { + case CONSTV: + result = cell->payload.cons.cdr; + break; + case KEYTV: + case STRINGTV: + case SYMBOLTV: + result = cell->payload.string.cdr; + break; + } } - } - return result; + return result; } /** * Implementation of `length` in C. If arg is not a cons, does not error but returns 0. */ -int c_length( struct cons_pointer arg) { +int c_length( struct cons_pointer arg ) { int result = 0; - for (struct cons_pointer c = arg; !nilp(c); c = c_cdr(c)) { - result ++; + for ( struct cons_pointer c = arg; !nilp( c ); c = c_cdr( c ) ) { + result++; } return result; @@ -276,27 +278,21 @@ struct cons_pointer make_nlambda( struct cons_pointer args, * * returns 0 for things which are not string like. */ -uint32_t calculate_hash(wint_t c, struct cons_pointer ptr) -{ - struct cons_space_object *cell = &pointer2cell(ptr); +uint32_t calculate_hash( wint_t c, struct cons_pointer ptr ) { + struct cons_space_object *cell = &pointer2cell( ptr ); uint32_t result = 0; - switch (cell->tag.value) - { - case KEYTV: - case STRINGTV: - case SYMBOLTV: - if (nilp(cell->payload.string.cdr)) - { - result = (uint32_t)c; - } - else - { - result = ((uint32_t)c * - cell->payload.string.hash) & - 0xffffffff; - } - break; + switch ( cell->tag.value ) { + case KEYTV: + case STRINGTV: + case SYMBOLTV: + if ( nilp( cell->payload.string.cdr ) ) { + result = ( uint32_t ) c; + } else { + result = ( ( uint32_t ) c * + cell->payload.string.hash ) & 0xffffffff; + } + break; } return result; @@ -324,7 +320,7 @@ make_string_like_thing( wint_t c, struct cons_pointer tail, uint32_t tag ) { * cell->payload.string.cdr = tail */ cell->payload.string.cdr.offset = tail.offset; - cell->payload.string.hash = calculate_hash(c, tail); + cell->payload.string.hash = calculate_hash( c, tail ); } else { // \todo should throw an exception! debug_printf( DEBUG_ALLOC, @@ -430,12 +426,12 @@ struct cons_pointer make_write_stream( URL_FILE * output, struct cons_pointer c_string_to_lisp_keyword( wchar_t *symbol ) { struct cons_pointer result = NIL; - for ( int i = wcslen( symbol ) -1; i >= 0; i-- ) { - wchar_t c = towlower(symbol[i]); + for ( int i = wcslen( symbol ) - 1; i >= 0; i-- ) { + wchar_t c = towlower( symbol[i] ); - if (iswalnum(c) || c == L'-') { - result = make_keyword( c, result ); - } + if ( iswalnum( c ) || c == L'-' ) { + result = make_keyword( c, result ); + } } return result; @@ -448,9 +444,9 @@ struct cons_pointer c_string_to_lisp_string( wchar_t *string ) { struct cons_pointer result = NIL; for ( int i = wcslen( string ) - 1; i >= 0; i-- ) { - if (iswprint(string[i]) && string[i] != '"') { - result = make_string( string[i], result ); - } + if ( iswprint( string[i] ) && string[i] != '"' ) { + result = make_string( string[i], result ); + } } return result; diff --git a/src/memory/consspaceobject.h b/src/memory/consspaceobject.h index 0efa0a6..2817e69 100644 --- a/src/memory/consspaceobject.h +++ b/src/memory/consspaceobject.h @@ -685,7 +685,7 @@ struct cons_pointer c_car( struct cons_pointer arg ); struct cons_pointer c_cdr( struct cons_pointer arg ); -int c_length( struct cons_pointer arg); +int c_length( struct cons_pointer arg ); struct cons_pointer make_cons( struct cons_pointer car, struct cons_pointer cdr ); diff --git a/src/memory/dump.c b/src/memory/dump.c index 2dc6658..086f8c8 100644 --- a/src/memory/dump.c +++ b/src/memory/dump.c @@ -46,8 +46,7 @@ void dump_string_cell( URL_FILE * output, wchar_t *prefix, cell.payload.string.character, cell.payload.string.hash, cell.payload.string.cdr.page, - cell.payload.string.cdr.offset, - cell.count ); + cell.payload.string.cdr.offset, cell.count ); url_fwprintf( output, L"\t\t value: " ); print( output, pointer ); url_fwprintf( output, L"\n" ); @@ -57,105 +56,111 @@ void dump_string_cell( URL_FILE * output, wchar_t *prefix, /** * dump the object at this cons_pointer to this output stream. */ -void dump_object( URL_FILE *output, struct cons_pointer pointer ) { - struct cons_space_object cell = pointer2cell( pointer ); - url_fwprintf( output, L"\t%4.4s (%d) at page %d, offset %d count %u\n", - cell.tag.bytes, cell.tag.value, pointer.page, pointer.offset, - cell.count ); +void dump_object( URL_FILE * output, struct cons_pointer pointer ) { + struct cons_space_object cell = pointer2cell( pointer ); + url_fwprintf( output, L"\t%4.4s (%d) at page %d, offset %d count %u\n", + cell.tag.bytes, cell.tag.value, pointer.page, pointer.offset, + cell.count ); - switch ( cell.tag.value ) { - case CONSTV: - url_fwprintf( output, - L"\t\tCons cell: car at page %d offset %d, cdr at page %d " - L"offset %d, count %u :", - cell.payload.cons.car.page, cell.payload.cons.car.offset, - cell.payload.cons.cdr.page, cell.payload.cons.cdr.offset, - cell.count ); - print( output, pointer ); - url_fputws( L"\n", output ); - break; - case EXCEPTIONTV: - url_fwprintf( output, L"\t\tException cell: " ); - dump_stack_trace( output, pointer ); - break; - case FREETV: - url_fwprintf( output, L"\t\tFree cell: next at page %d offset %d\n", - cell.payload.cons.cdr.page, cell.payload.cons.cdr.offset ); - break; - case INTEGERTV: - url_fwprintf( output, L"\t\tInteger cell: value %ld, count %u\n", - cell.payload.integer.value, cell.count ); - if ( !nilp( cell.payload.integer.more ) ) { - url_fputws( L"\t\tBIGNUM! More at:\n", output ); - dump_object( output, cell.payload.integer.more ); - } - break; - case KEYTV: - dump_string_cell( output, L"Keyword", pointer ); - break; - case LAMBDATV: - url_fwprintf( output, L"\t\t\u03bb cell;\n\t\t args: " ); - print( output, cell.payload.lambda.args ); - url_fwprintf( output, L";\n\t\t\tbody: " ); - print( output, cell.payload.lambda.body ); - url_fputws( L"\n", output ); - break; - case NILTV: - break; - case NLAMBDATV: - url_fwprintf( output, L"\t\tn\u03bb cell; \n\t\targs: " ); - print( output, cell.payload.lambda.args ); - url_fwprintf( output, L";\n\t\t\tbody: " ); - print( output, cell.payload.lambda.body ); - url_fputws( L"\n", output ); - break; - case RATIOTV: - url_fwprintf( - output, L"\t\tRational cell: value %ld/%ld, count %u\n", - pointer2cell( cell.payload.ratio.dividend ).payload.integer.value, - pointer2cell( cell.payload.ratio.divisor ).payload.integer.value, - cell.count ); - break; - case READTV: - url_fputws( L"\t\tInput stream; metadata: ", output ); - print( output, cell.payload.stream.meta ); - url_fputws( L"\n", output ); - break; - case REALTV: - url_fwprintf( output, L"\t\tReal cell: value %Lf, count %u\n", - cell.payload.real.value, cell.count ); - break; - case STRINGTV: - dump_string_cell( output, L"String", pointer ); - break; - case SYMBOLTV: - dump_string_cell( output, L"Symbol", pointer ); - break; - case TRUETV: - break; - case VECTORPOINTTV: { - url_fwprintf( output, L"\t\tPointer to vector-space object at %p\n", - cell.payload.vectorp.address ); - struct vector_space_object *vso = cell.payload.vectorp.address; - url_fwprintf( output, - L"\t\tVector space object of type %4.4s (%d), payload size " - L"%d bytes\n", - &vso->header.tag.bytes, vso->header.tag.value, - vso->header.size ); + switch ( cell.tag.value ) { + case CONSTV: + url_fwprintf( output, + L"\t\tCons cell: car at page %d offset %d, cdr at page %d " + L"offset %d, count %u :", + cell.payload.cons.car.page, + cell.payload.cons.car.offset, + cell.payload.cons.cdr.page, + cell.payload.cons.cdr.offset, cell.count ); + print( output, pointer ); + url_fputws( L"\n", output ); + break; + case EXCEPTIONTV: + url_fwprintf( output, L"\t\tException cell: " ); + dump_stack_trace( output, pointer ); + break; + case FREETV: + url_fwprintf( output, + L"\t\tFree cell: next at page %d offset %d\n", + cell.payload.cons.cdr.page, + cell.payload.cons.cdr.offset ); + break; + case INTEGERTV: + url_fwprintf( output, L"\t\tInteger cell: value %ld, count %u\n", + cell.payload.integer.value, cell.count ); + if ( !nilp( cell.payload.integer.more ) ) { + url_fputws( L"\t\tBIGNUM! More at:\n", output ); + dump_object( output, cell.payload.integer.more ); + } + break; + case KEYTV: + dump_string_cell( output, L"Keyword", pointer ); + break; + case LAMBDATV: + url_fwprintf( output, L"\t\t\u03bb cell;\n\t\t args: " ); + print( output, cell.payload.lambda.args ); + url_fwprintf( output, L";\n\t\t\tbody: " ); + print( output, cell.payload.lambda.body ); + url_fputws( L"\n", output ); + break; + case NILTV: + break; + case NLAMBDATV: + url_fwprintf( output, L"\t\tn\u03bb cell; \n\t\targs: " ); + print( output, cell.payload.lambda.args ); + url_fwprintf( output, L";\n\t\t\tbody: " ); + print( output, cell.payload.lambda.body ); + url_fputws( L"\n", output ); + break; + case RATIOTV: + url_fwprintf( output, + L"\t\tRational cell: value %ld/%ld, count %u\n", + pointer2cell( cell.payload.ratio.dividend ).payload. + integer.value, + pointer2cell( cell.payload.ratio.divisor ).payload. + integer.value, cell.count ); + break; + case READTV: + url_fputws( L"\t\tInput stream; metadata: ", output ); + print( output, cell.payload.stream.meta ); + url_fputws( L"\n", output ); + break; + case REALTV: + url_fwprintf( output, L"\t\tReal cell: value %Lf, count %u\n", + cell.payload.real.value, cell.count ); + break; + case STRINGTV: + dump_string_cell( output, L"String", pointer ); + break; + case SYMBOLTV: + dump_string_cell( output, L"Symbol", pointer ); + break; + case TRUETV: + break; + case VECTORPOINTTV:{ + url_fwprintf( output, + L"\t\tPointer to vector-space object at %p\n", + cell.payload.vectorp.address ); + struct vector_space_object *vso = cell.payload.vectorp.address; + url_fwprintf( output, + L"\t\tVector space object of type %4.4s (%d), payload size " + L"%d bytes\n", + &vso->header.tag.bytes, vso->header.tag.value, + vso->header.size ); - switch ( vso->header.tag.value ) { - case STACKFRAMETV: - dump_frame( output, pointer ); - break; - case HASHTV: - dump_map( output, pointer ); - break; - } - } break; - case WRITETV: - url_fputws( L"\t\tOutput stream; metadata: ", output ); - print( output, cell.payload.stream.meta ); - url_fputws( L"\n", output ); - break; - } + switch ( vso->header.tag.value ) { + case STACKFRAMETV: + dump_frame( output, pointer ); + break; + case HASHTV: + dump_map( output, pointer ); + break; + } + } + break; + case WRITETV: + url_fputws( L"\t\tOutput stream; metadata: ", output ); + print( output, cell.payload.stream.meta ); + url_fputws( L"\n", output ); + break; + } } diff --git a/src/memory/hashmap.c b/src/memory/hashmap.c index ae15461..2e68cda 100644 --- a/src/memory/hashmap.c +++ b/src/memory/hashmap.c @@ -24,47 +24,46 @@ * then `(sxhash x)` and `(sxhash y)` will always be equal. */ uint32_t sxhash( struct cons_pointer ptr ) { - // TODO: Not Yet Implemented - /* TODO: should look at the implementation of Common Lisp sxhash? - * My current implementation of `print` only addresses URL_FILE - * streams. It would be better if it also addressed strings but - * currently it doesn't. Creating a print string of the structure - * and taking the hash of that would be one simple (but not necessarily - * cheap) solution. - */ - /* TODO: sbcl's implementation of `sxhash` is in src/compiler/sxhash.lisp - * and is EXTREMELY complex, and essentially has a different dispatch for - * every type of object. It's likely we need to do the same. - */ - return 0; + // TODO: Not Yet Implemented + /* TODO: should look at the implementation of Common Lisp sxhash? + * My current implementation of `print` only addresses URL_FILE + * streams. It would be better if it also addressed strings but + * currently it doesn't. Creating a print string of the structure + * and taking the hash of that would be one simple (but not necessarily + * cheap) solution. + */ + /* TODO: sbcl's implementation of `sxhash` is in src/compiler/sxhash.lisp + * and is EXTREMELY complex, and essentially has a different dispatch for + * every type of object. It's likely we need to do the same. + */ + return 0; } /** * Get the hash value for the cell indicated by this `ptr`; currently only * implemented for string like things and integers. */ -uint32_t get_hash(struct cons_pointer ptr) -{ - struct cons_space_object *cell = &pointer2cell(ptr); +uint32_t get_hash( struct cons_pointer ptr ) { + struct cons_space_object *cell = &pointer2cell( ptr ); uint32_t result = 0; switch ( cell->tag.value ) { - case INTEGERTV: - /* Note that we're only hashing on the least significant word of an - * integer. */ - result = cell->payload.integer.value & 0xffffffff; - break; - case KEYTV: - case STRINGTV: - case SYMBOLTV: - result = cell->payload.string.hash; - break; - case TRUETV: - result = 1; // arbitrarily - break; - default: - result = sxhash( ptr ); - break; + case INTEGERTV: + /* Note that we're only hashing on the least significant word of an + * integer. */ + result = cell->payload.integer.value & 0xffffffff; + break; + case KEYTV: + case STRINGTV: + case SYMBOLTV: + result = cell->payload.string.hash; + break; + case TRUETV: + result = 1; // arbitrarily + break; + default: + result = sxhash( ptr ); + break; } return result; @@ -74,35 +73,34 @@ uint32_t get_hash(struct cons_pointer ptr) * Free the hashmap indicated by this `pointer`. */ void free_hashmap( struct cons_pointer pointer ) { - struct cons_space_object *cell = &pointer2cell( pointer ); + struct cons_space_object *cell = &pointer2cell( pointer ); - if ( hashmapp( pointer ) ) { - struct vector_space_object *vso = cell->payload.vectorp.address; + if ( hashmapp( pointer ) ) { + struct vector_space_object *vso = cell->payload.vectorp.address; - dec_ref( vso->payload.hashmap.hash_fn ); - dec_ref( vso->payload.hashmap.write_acl ); + dec_ref( vso->payload.hashmap.hash_fn ); + dec_ref( vso->payload.hashmap.write_acl ); - for ( int i = 0; i < vso->payload.hashmap.n_buckets; i++ ) { - if ( !nilp( vso->payload.hashmap.buckets[i] ) ) { - debug_printf( DEBUG_ALLOC, - L"Decrementing bucket [%d] of hashmap at 0x%lx\n", i, - cell->payload.vectorp.address ); - dec_ref( vso->payload.hashmap.buckets[i] ); - } + for ( int i = 0; i < vso->payload.hashmap.n_buckets; i++ ) { + if ( !nilp( vso->payload.hashmap.buckets[i] ) ) { + debug_printf( DEBUG_ALLOC, + L"Decrementing bucket [%d] of hashmap at 0x%lx\n", + i, cell->payload.vectorp.address ); + dec_ref( vso->payload.hashmap.buckets[i] ); + } + } + } else { + debug_printf( DEBUG_ALLOC, L"Non-hashmap passed to `free_hashmap`\n" ); } - } else { - debug_printf( DEBUG_ALLOC, L"Non-hashmap passed to `free_hashmap`\n" ); - } } /** * A lisp function signature conforming wrapper around get_hash, q.v.. */ -struct cons_pointer lisp_get_hash(struct stack_frame *frame, - struct cons_pointer frame_pointer, - struct cons_pointer env) -{ - return make_integer(get_hash(frame->arg[0]), NIL); +struct cons_pointer lisp_get_hash( struct stack_frame *frame, + struct cons_pointer frame_pointer, + struct cons_pointer env ) { + return make_integer( get_hash( frame->arg[0] ), NIL ); } /** @@ -112,22 +110,23 @@ struct cons_pointer lisp_get_hash(struct stack_frame *frame, struct cons_pointer make_hashmap( uint32_t n_buckets, struct cons_pointer hash_fn, struct cons_pointer write_acl ) { - struct cons_pointer result = - make_vso( HASHTV, ( sizeof( struct cons_pointer ) * ( n_buckets + 1 ) ) + - ( sizeof( uint32_t ) * 2 ) ); + struct cons_pointer result = + make_vso( HASHTV, + ( sizeof( struct cons_pointer ) * ( n_buckets + 1 ) ) + + ( sizeof( uint32_t ) * 2 ) ); - struct hashmap_payload *payload = - (struct hashmap_payload *)&pointer_to_vso( result )->payload; + struct hashmap_payload *payload = + ( struct hashmap_payload * ) &pointer_to_vso( result )->payload; - payload->hash_fn = inc_ref(hash_fn); - payload->write_acl = inc_ref(write_acl); + payload->hash_fn = inc_ref( hash_fn ); + payload->write_acl = inc_ref( write_acl ); - payload->n_buckets = n_buckets; - for ( int i = 0; i < n_buckets; i++ ) { - payload->buckets[i] = NIL; - } + payload->n_buckets = n_buckets; + for ( int i = 0; i < n_buckets; i++ ) { + payload->buckets[i] = NIL; + } - return result; + return result; } /** @@ -141,52 +140,54 @@ struct cons_pointer make_hashmap( uint32_t n_buckets, struct cons_pointer lisp_make_hashmap( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ) { - uint32_t n = DFLT_HASHMAP_BUCKETS; - struct cons_pointer hash_fn = NIL; - struct cons_pointer result = NIL; + uint32_t n = DFLT_HASHMAP_BUCKETS; + struct cons_pointer hash_fn = NIL; + struct cons_pointer result = NIL; - if ( frame->args > 0 ) { - if ( integerp( frame->arg[0] ) ) { - n = to_long_int( frame->arg[0] ) % UINT32_MAX; - } else if ( !nilp( frame->arg[0] ) ) { - result = make_exception( - c_string_to_lisp_string( L"First arg to `hashmap`, if passed, must " - L"be an integer or `nil`.`" ), - NIL ); + if ( frame->args > 0 ) { + if ( integerp( frame->arg[0] ) ) { + n = to_long_int( frame->arg[0] ) % UINT32_MAX; + } else if ( !nilp( frame->arg[0] ) ) { + result = + make_exception( c_string_to_lisp_string + ( L"First arg to `hashmap`, if passed, must " + L"be an integer or `nil`.`" ), NIL ); + } } - } - if ( frame->args > 1 ) { - hash_fn = frame->arg[1]; - } - - if ( nilp( result ) ) { - /* if there are fewer than 4 args, then arg[3] ought to be nil anyway, which - * is fine */ - result = make_hashmap( n, hash_fn, frame->arg[3] ); - struct vector_space_object *map = pointer_to_vso( result ); - - if ( frame->args > 2 && - truep( authorised( result, map->payload.hashmap.write_acl ) ) ) { - // then arg[2] ought to be an assoc list which we should iterate down - // populating the hashmap. - for ( struct cons_pointer cursor = frame->arg[2]; !nilp( cursor ); - cursor = c_cdr( cursor ) ) { - struct cons_pointer pair = c_car( cursor ); - struct cons_pointer key = c_car( pair ); - struct cons_pointer val = c_cdr( pair ); - - uint32_t bucket_no = - get_hash( key ) % - ( (struct hashmap_payload *)&( map->payload ) )->n_buckets; - - map->payload.hashmap.buckets[bucket_no] = - inc_ref( make_cons( make_cons( key, val ), - map->payload.hashmap.buckets[bucket_no] )); - } + if ( frame->args > 1 ) { + hash_fn = frame->arg[1]; } - } - return result; + if ( nilp( result ) ) { + /* if there are fewer than 4 args, then arg[3] ought to be nil anyway, which + * is fine */ + result = make_hashmap( n, hash_fn, frame->arg[3] ); + struct vector_space_object *map = pointer_to_vso( result ); + + if ( frame->args > 2 && + truep( authorised( result, map->payload.hashmap.write_acl ) ) ) { + // then arg[2] ought to be an assoc list which we should iterate down + // populating the hashmap. + for ( struct cons_pointer cursor = frame->arg[2]; !nilp( cursor ); + cursor = c_cdr( cursor ) ) { + struct cons_pointer pair = c_car( cursor ); + struct cons_pointer key = c_car( pair ); + struct cons_pointer val = c_cdr( pair ); + + uint32_t bucket_no = + get_hash( key ) % + ( ( struct hashmap_payload * ) &( map->payload ) )-> + n_buckets; + + map->payload.hashmap.buckets[bucket_no] = + inc_ref( make_cons( make_cons( key, val ), + map->payload.hashmap. + buckets[bucket_no] ) ); + } + } + } + + return result; } @@ -197,28 +198,30 @@ struct cons_pointer lisp_make_hashmap( struct stack_frame *frame, * readable hashmap. */ struct cons_pointer clone_hashmap( struct cons_pointer ptr ) { - struct cons_pointer result = NIL; + struct cons_pointer result = NIL; - if ( truep( authorised( ptr, NIL ) ) ) { - if ( hashmapp( ptr ) ) { - struct vector_space_object *from = pointer_to_vso( ptr ); + if ( truep( authorised( ptr, NIL ) ) ) { + if ( hashmapp( ptr ) ) { + struct vector_space_object *from = pointer_to_vso( ptr ); - if ( from != NULL ) { - struct hashmap_payload from_pl = from->payload.hashmap; - result = make_hashmap( from_pl.n_buckets, from_pl.hash_fn, from_pl.write_acl ); - struct vector_space_object *to = pointer_to_vso( result ); - struct hashmap_payload to_pl = to->payload.hashmap; + if ( from != NULL ) { + struct hashmap_payload from_pl = from->payload.hashmap; + result = + make_hashmap( from_pl.n_buckets, from_pl.hash_fn, + from_pl.write_acl ); + struct vector_space_object *to = pointer_to_vso( result ); + struct hashmap_payload to_pl = to->payload.hashmap; - for ( int i = 0; i < to_pl.n_buckets; i++ ) { - to_pl.buckets[i] = from_pl.buckets[i]; - inc_ref( to_pl.buckets[i] ); + for ( int i = 0; i < to_pl.n_buckets; i++ ) { + to_pl.buckets[i] = from_pl.buckets[i]; + inc_ref( to_pl.buckets[i] ); + } + } } - } } - } - // TODO: else exception? + // TODO: else exception? - return result; + return result; } /** @@ -229,37 +232,35 @@ struct cons_pointer clone_hashmap( struct cons_pointer ptr ) { struct cons_pointer hashmap_put( struct cons_pointer mapp, struct cons_pointer key, struct cons_pointer val ) { - // TODO: if current user has write access to this hashmap - if ( hashmapp( mapp ) && !nilp( key ) ) { - struct vector_space_object *map = pointer_to_vso( mapp ); + // TODO: if current user has write access to this hashmap + if ( hashmapp( mapp ) && !nilp( key ) ) { + struct vector_space_object *map = pointer_to_vso( mapp ); - if (nilp(authorised(mapp, map->payload.hashmap.write_acl))) { - mapp = clone_hashmap( mapp); - map = pointer_to_vso( mapp ); - } - uint32_t bucket_no = - get_hash( key ) % - map->payload.hashmap.n_buckets; + if ( nilp( authorised( mapp, map->payload.hashmap.write_acl ) ) ) { + mapp = clone_hashmap( mapp ); + map = pointer_to_vso( mapp ); + } + uint32_t bucket_no = get_hash( key ) % map->payload.hashmap.n_buckets; map->payload.hashmap.buckets[bucket_no] = inc_ref( make_cons( make_cons( key, val ), - map->payload.hashmap.buckets[bucket_no] )); - } + map->payload.hashmap.buckets[bucket_no] ) ); + } - return mapp; + return mapp; } struct cons_pointer hashmap_get( struct cons_pointer mapp, struct cons_pointer key ) { - struct cons_pointer result = NIL; - if ( hashmapp( mapp ) && truep( authorised( mapp, NIL ) ) && !nilp( key ) ) { - struct vector_space_object *map = pointer_to_vso( mapp ); - uint32_t bucket_no = get_hash( key ) % map->payload.hashmap.n_buckets; + struct cons_pointer result = NIL; + if ( hashmapp( mapp ) && truep( authorised( mapp, NIL ) ) && !nilp( key ) ) { + struct vector_space_object *map = pointer_to_vso( mapp ); + uint32_t bucket_no = get_hash( key ) % map->payload.hashmap.n_buckets; - result = c_assoc( key, map->payload.hashmap.buckets[bucket_no] ); - } + result = c_assoc( key, map->payload.hashmap.buckets[bucket_no] ); + } - return result; + return result; } /** @@ -272,11 +273,11 @@ struct cons_pointer hashmap_get( struct cons_pointer mapp, struct cons_pointer lisp_hashmap_put( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ) { - struct cons_pointer mapp = frame->arg[0]; - struct cons_pointer key = frame->arg[1]; - struct cons_pointer val = frame->arg[2]; + struct cons_pointer mapp = frame->arg[0]; + struct cons_pointer key = frame->arg[1]; + struct cons_pointer val = frame->arg[2]; - return hashmap_put(mapp, key, val); + return hashmap_put( mapp, key, val ); } /** @@ -286,21 +287,21 @@ struct cons_pointer lisp_hashmap_put( struct stack_frame *frame, */ struct cons_pointer hashmap_put_all( struct cons_pointer mapp, struct cons_pointer assoc ) { - // TODO: if current user has write access to this hashmap - if ( hashmapp( mapp ) && !nilp( assoc ) ) { - struct vector_space_object *map = pointer_to_vso( mapp ); + // TODO: if current user has write access to this hashmap + if ( hashmapp( mapp ) && !nilp( assoc ) ) { + struct vector_space_object *map = pointer_to_vso( mapp ); - if ( hashmapp( mapp ) && consp( assoc ) ) { - for ( struct cons_pointer pair = c_car( assoc ); !nilp( pair ); - pair = c_car( assoc ) ) { - /* TODO: this is really hammering the memory management system, because - * it will make a new lone for every key/value pair added. Fix. */ - mapp = hashmap_put( mapp, c_car( pair ), c_cdr( pair ) ); - } + if ( hashmapp( mapp ) && consp( assoc ) ) { + for ( struct cons_pointer pair = c_car( assoc ); !nilp( pair ); + pair = c_car( assoc ) ) { + /* TODO: this is really hammering the memory management system, because + * it will make a new lone for every key/value pair added. Fix. */ + mapp = hashmap_put( mapp, c_car( pair ), c_cdr( pair ) ); + } + } } - } - return mapp; + return mapp; } /** @@ -310,47 +311,47 @@ struct cons_pointer hashmap_put_all( struct cons_pointer mapp, struct cons_pointer lisp_hashmap_put_all( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ) { - return hashmap_put_all( frame->arg[0], frame->arg[1] ); + return hashmap_put_all( frame->arg[0], frame->arg[1] ); } /** * return a flat list of all the keys in the hashmap indicated by `map`. */ -struct cons_pointer hashmap_keys( struct cons_pointer mapp) { - struct cons_pointer result = NIL; - if ( hashmapp( mapp ) && truep( authorised( mapp, NIL ) )) { +struct cons_pointer hashmap_keys( struct cons_pointer mapp ) { + struct cons_pointer result = NIL; + if ( hashmapp( mapp ) && truep( authorised( mapp, NIL ) ) ) { struct vector_space_object *map = pointer_to_vso( mapp ); - for (int i = 0; i < map->payload.hashmap.n_buckets; i++) { - for (struct cons_pointer c = map->payload.hashmap.buckets[i]; - !nilp(c); - c = c_cdr(c)) { - result = make_cons(c_car( c_car(c)), result); - } + for ( int i = 0; i < map->payload.hashmap.n_buckets; i++ ) { + for ( struct cons_pointer c = map->payload.hashmap.buckets[i]; + !nilp( c ); c = c_cdr( c ) ) { + result = make_cons( c_car( c_car( c ) ), result ); + } + } } - } - return result; + return result; } struct cons_pointer lisp_hashmap_keys( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ) { - return hashmap_keys( frame->arg[0] ); + return hashmap_keys( frame->arg[0] ); } -void dump_map( URL_FILE *output, struct cons_pointer pointer ) { - struct hashmap_payload *payload = &pointer_to_vso( pointer )->payload.hashmap; - url_fwprintf( output, L"Hashmap with %d buckets:\n", payload->n_buckets ); - url_fwprintf( output, L"\tHash function: " ); - print( output, payload->hash_fn ); - url_fwprintf( output, L"\n\tWrite ACL: " ); - print( output, payload->write_acl ); - url_fwprintf( output, L"\n\tBuckets:" ); - for ( int i = 0; i < payload->n_buckets; i++ ) { - url_fwprintf( output, L"\n\t\t[%d]: ", i ); - print( output, payload->buckets[i] ); - } - url_fwprintf( output, L"\n" ); +void dump_map( URL_FILE * output, struct cons_pointer pointer ) { + struct hashmap_payload *payload = + &pointer_to_vso( pointer )->payload.hashmap; + url_fwprintf( output, L"Hashmap with %d buckets:\n", payload->n_buckets ); + url_fwprintf( output, L"\tHash function: " ); + print( output, payload->hash_fn ); + url_fwprintf( output, L"\n\tWrite ACL: " ); + print( output, payload->write_acl ); + url_fwprintf( output, L"\n\tBuckets:" ); + for ( int i = 0; i < payload->n_buckets; i++ ) { + url_fwprintf( output, L"\n\t\t[%d]: ", i ); + print( output, payload->buckets[i] ); + } + url_fwprintf( output, L"\n" ); } diff --git a/src/memory/hashmap.h b/src/memory/hashmap.h index 4602f3e..b6c4a74 100644 --- a/src/memory/hashmap.h +++ b/src/memory/hashmap.h @@ -15,13 +15,13 @@ #include "memory/consspaceobject.h" #include "memory/vectorspace.h" -#define DFLT_HASHMAP_BUCKETS 32 +#define DFLT_HASHMAP_BUCKETS 32 uint32_t get_hash( struct cons_pointer ptr ); void free_hashmap( struct cons_pointer ptr ); -void dump_map( URL_FILE *output, struct cons_pointer pointer ); +void dump_map( URL_FILE * output, struct cons_pointer pointer ); struct cons_pointer hashmap_get( struct cons_pointer mapp, struct cons_pointer key ); @@ -52,4 +52,4 @@ struct cons_pointer make_hashmap( uint32_t n_buckets, struct cons_pointer hash_fn, struct cons_pointer write_acl ); -#endif \ No newline at end of file +#endif diff --git a/src/memory/lookup3.c b/src/memory/lookup3.c index 006d513..359cff2 100644 --- a/src/memory/lookup3.c +++ b/src/memory/lookup3.c @@ -35,12 +35,12 @@ on 1 byte), but shoehorning those bytes into integers efficiently is messy. */ // #define SELF_TEST 1 -#include /* defines printf for tests */ -#include /* defines time_t for timings in the test */ -#include /* defines uint32_t etc */ -#include /* attempt to define endianness */ +#include /* defines printf for tests */ +#include /* defines time_t for timings in the test */ +#include /* defines uint32_t etc */ +#include /* attempt to define endianness */ #ifdef linux -# include /* attempt to define endianness */ +#include /* attempt to define endianness */ #endif /* @@ -51,16 +51,16 @@ on 1 byte), but shoehorning those bytes into integers efficiently is messy. __BYTE_ORDER == __LITTLE_ENDIAN) || \ (defined(i386) || defined(__i386__) || defined(__i486__) || \ defined(__i586__) || defined(__i686__) || defined(vax) || defined(MIPSEL)) -# define HASH_LITTLE_ENDIAN 1 -# define HASH_BIG_ENDIAN 0 +#define HASH_LITTLE_ENDIAN 1 +#define HASH_BIG_ENDIAN 0 #elif (defined(__BYTE_ORDER) && defined(__BIG_ENDIAN) && \ __BYTE_ORDER == __BIG_ENDIAN) || \ (defined(sparc) || defined(POWERPC) || defined(mc68000) || defined(sel)) -# define HASH_LITTLE_ENDIAN 0 -# define HASH_BIG_ENDIAN 1 +#define HASH_LITTLE_ENDIAN 0 +#define HASH_BIG_ENDIAN 1 #else -# define HASH_LITTLE_ENDIAN 0 -# define HASH_BIG_ENDIAN 0 +#define HASH_LITTLE_ENDIAN 0 +#define HASH_BIG_ENDIAN 0 #endif #define hashsize(n) ((uint32_t)1<<(n)) @@ -170,39 +170,38 @@ and these came close: hashlittle() has to dance around fitting the key bytes into registers. -------------------------------------------------------------------- */ -uint32_t hashword( -const uint32_t *k, /* the key, an array of uint32_t values */ -size_t length, /* the length of the key, in uint32_ts */ -uint32_t initval) /* the previous hash, or an arbitrary value */ -{ - uint32_t a,b,c; +uint32_t hashword( const uint32_t * k, /* the key, an array of uint32_t values */ + size_t length, /* the length of the key, in uint32_ts */ + uint32_t initval ) { /* the previous hash, or an arbitrary value */ + uint32_t a, b, c; - /* Set up the internal state */ - a = b = c = 0xdeadbeef + (((uint32_t)length)<<2) + initval; + /* Set up the internal state */ + a = b = c = 0xdeadbeef + ( ( ( uint32_t ) length ) << 2 ) + initval; /*------------------------------------------------- handle most of the key */ - while (length > 3) - { - a += k[0]; - b += k[1]; - c += k[2]; - mix(a,b,c); - length -= 3; - k += 3; - } + while ( length > 3 ) { + a += k[0]; + b += k[1]; + c += k[2]; + mix( a, b, c ); + length -= 3; + k += 3; + } /*------------------------------------------- handle the last 3 uint32_t's */ - switch(length) /* all the case statements fall through */ - { - case 3 : c+=k[2]; - case 2 : b+=k[1]; - case 1 : a+=k[0]; - final(a,b,c); - case 0: /* case 0: nothing left to add */ - break; - } + switch ( length ) { /* all the case statements fall through */ + case 3: + c += k[2]; + case 2: + b += k[1]; + case 1: + a += k[0]; + final( a, b, c ); + case 0: /* case 0: nothing left to add */ + break; + } /*------------------------------------------------------ report the result */ - return c; + return c; } @@ -214,41 +213,41 @@ both be initialized with seeds. If you pass in (*pb)==0, the output (*pc) will be the same as the return value from hashword(). -------------------------------------------------------------------- */ -void hashword2 ( -const uint32_t *k, /* the key, an array of uint32_t values */ -size_t length, /* the length of the key, in uint32_ts */ -uint32_t *pc, /* IN: seed OUT: primary hash value */ -uint32_t *pb) /* IN: more seed OUT: secondary hash value */ -{ - uint32_t a,b,c; +void hashword2( const uint32_t * k, /* the key, an array of uint32_t values */ + size_t length, /* the length of the key, in uint32_ts */ + uint32_t * pc, /* IN: seed OUT: primary hash value */ + uint32_t * pb ) { /* IN: more seed OUT: secondary hash value */ + uint32_t a, b, c; - /* Set up the internal state */ - a = b = c = 0xdeadbeef + ((uint32_t)(length<<2)) + *pc; - c += *pb; + /* Set up the internal state */ + a = b = c = 0xdeadbeef + ( ( uint32_t ) ( length << 2 ) ) + *pc; + c += *pb; /*------------------------------------------------- handle most of the key */ - while (length > 3) - { - a += k[0]; - b += k[1]; - c += k[2]; - mix(a,b,c); - length -= 3; - k += 3; - } + while ( length > 3 ) { + a += k[0]; + b += k[1]; + c += k[2]; + mix( a, b, c ); + length -= 3; + k += 3; + } /*------------------------------------------- handle the last 3 uint32_t's */ - switch(length) /* all the case statements fall through */ - { - case 3 : c+=k[2]; - case 2 : b+=k[1]; - case 1 : a+=k[0]; - final(a,b,c); - case 0: /* case 0: nothing left to add */ - break; - } + switch ( length ) { /* all the case statements fall through */ + case 3: + c += k[2]; + case 2: + b += k[1]; + case 1: + a += k[0]; + final( a, b, c ); + case 0: /* case 0: nothing left to add */ + break; + } /*------------------------------------------------------ report the result */ - *pc=c; *pb=b; + *pc = c; + *pb = b; } @@ -279,173 +278,251 @@ acceptable. Do NOT use for cryptographic purposes. ------------------------------------------------------------------------------- */ -uint32_t hashlittle( const void *key, size_t length, uint32_t initval) -{ - uint32_t a,b,c; /* internal state */ - union { const void *ptr; size_t i; } u; /* needed for Mac Powerbook G4 */ +uint32_t hashlittle( const void *key, size_t length, uint32_t initval ) { + uint32_t a, b, c; /* internal state */ + union { + const void *ptr; + size_t i; + } u; /* needed for Mac Powerbook G4 */ - /* Set up the internal state */ - a = b = c = 0xdeadbeef + ((uint32_t)length) + initval; + /* Set up the internal state */ + a = b = c = 0xdeadbeef + ( ( uint32_t ) length ) + initval; - u.ptr = key; - if (HASH_LITTLE_ENDIAN && ((u.i & 0x3) == 0)) { - const uint32_t *k = (const uint32_t *)key; /* read 32-bit chunks */ - const uint8_t *k8; + u.ptr = key; + if ( HASH_LITTLE_ENDIAN && ( ( u.i & 0x3 ) == 0 ) ) { + const uint32_t *k = ( const uint32_t * ) key; /* read 32-bit chunks */ + const uint8_t *k8; /*------ all but last block: aligned reads and affect 32 bits of (a,b,c) */ - while (length > 12) - { - a += k[0]; - b += k[1]; - c += k[2]; - mix(a,b,c); - length -= 12; - k += 3; - } + while ( length > 12 ) { + a += k[0]; + b += k[1]; + c += k[2]; + mix( a, b, c ); + length -= 12; + k += 3; + } /*----------------------------- handle the last (probably partial) block */ - /* - * "k[2]&0xffffff" actually reads beyond the end of the string, but - * then masks off the part it's not allowed to read. Because the - * string is aligned, the masked-off tail is in the same word as the - * rest of the string. Every machine with memory protection I've seen - * does it on word boundaries, so is OK with this. But VALGRIND will - * still catch it and complain. The masking trick does make the hash - * noticably faster for short strings (like English words). - */ + /* + * "k[2]&0xffffff" actually reads beyond the end of the string, but + * then masks off the part it's not allowed to read. Because the + * string is aligned, the masked-off tail is in the same word as the + * rest of the string. Every machine with memory protection I've seen + * does it on word boundaries, so is OK with this. But VALGRIND will + * still catch it and complain. The masking trick does make the hash + * noticably faster for short strings (like English words). + */ #ifndef VALGRIND - switch(length) - { - case 12: c+=k[2]; b+=k[1]; a+=k[0]; break; - case 11: c+=k[2]&0xffffff; b+=k[1]; a+=k[0]; break; - case 10: c+=k[2]&0xffff; b+=k[1]; a+=k[0]; break; - case 9 : c+=k[2]&0xff; b+=k[1]; a+=k[0]; break; - case 8 : b+=k[1]; a+=k[0]; break; - case 7 : b+=k[1]&0xffffff; a+=k[0]; break; - case 6 : b+=k[1]&0xffff; a+=k[0]; break; - case 5 : b+=k[1]&0xff; a+=k[0]; break; - case 4 : a+=k[0]; break; - case 3 : a+=k[0]&0xffffff; break; - case 2 : a+=k[0]&0xffff; break; - case 1 : a+=k[0]&0xff; break; - case 0 : return c; /* zero length strings require no mixing */ - } + switch ( length ) { + case 12: + c += k[2]; + b += k[1]; + a += k[0]; + break; + case 11: + c += k[2] & 0xffffff; + b += k[1]; + a += k[0]; + break; + case 10: + c += k[2] & 0xffff; + b += k[1]; + a += k[0]; + break; + case 9: + c += k[2] & 0xff; + b += k[1]; + a += k[0]; + break; + case 8: + b += k[1]; + a += k[0]; + break; + case 7: + b += k[1] & 0xffffff; + a += k[0]; + break; + case 6: + b += k[1] & 0xffff; + a += k[0]; + break; + case 5: + b += k[1] & 0xff; + a += k[0]; + break; + case 4: + a += k[0]; + break; + case 3: + a += k[0] & 0xffffff; + break; + case 2: + a += k[0] & 0xffff; + break; + case 1: + a += k[0] & 0xff; + break; + case 0: + return c; /* zero length strings require no mixing */ + } #else /* make valgrind happy */ - k8 = (const uint8_t *)k; - switch(length) - { - case 12: c+=k[2]; b+=k[1]; a+=k[0]; break; - case 11: c+=((uint32_t)k8[10])<<16; /* fall through */ - case 10: c+=((uint32_t)k8[9])<<8; /* fall through */ - case 9 : c+=k8[8]; /* fall through */ - case 8 : b+=k[1]; a+=k[0]; break; - case 7 : b+=((uint32_t)k8[6])<<16; /* fall through */ - case 6 : b+=((uint32_t)k8[5])<<8; /* fall through */ - case 5 : b+=k8[4]; /* fall through */ - case 4 : a+=k[0]; break; - case 3 : a+=((uint32_t)k8[2])<<16; /* fall through */ - case 2 : a+=((uint32_t)k8[1])<<8; /* fall through */ - case 1 : a+=k8[0]; break; - case 0 : return c; - } + k8 = ( const uint8_t * ) k; + switch ( length ) { + case 12: + c += k[2]; + b += k[1]; + a += k[0]; + break; + case 11: + c += ( ( uint32_t ) k8[10] ) << 16; /* fall through */ + case 10: + c += ( ( uint32_t ) k8[9] ) << 8; /* fall through */ + case 9: + c += k8[8]; /* fall through */ + case 8: + b += k[1]; + a += k[0]; + break; + case 7: + b += ( ( uint32_t ) k8[6] ) << 16; /* fall through */ + case 6: + b += ( ( uint32_t ) k8[5] ) << 8; /* fall through */ + case 5: + b += k8[4]; /* fall through */ + case 4: + a += k[0]; + break; + case 3: + a += ( ( uint32_t ) k8[2] ) << 16; /* fall through */ + case 2: + a += ( ( uint32_t ) k8[1] ) << 8; /* fall through */ + case 1: + a += k8[0]; + break; + case 0: + return c; + } #endif /* !valgrind */ - } else if (HASH_LITTLE_ENDIAN && ((u.i & 0x1) == 0)) { - const uint16_t *k = (const uint16_t *)key; /* read 16-bit chunks */ - const uint8_t *k8; + } else if ( HASH_LITTLE_ENDIAN && ( ( u.i & 0x1 ) == 0 ) ) { + const uint16_t *k = ( const uint16_t * ) key; /* read 16-bit chunks */ + const uint8_t *k8; /*--------------- all but last block: aligned reads and different mixing */ - while (length > 12) - { - a += k[0] + (((uint32_t)k[1])<<16); - b += k[2] + (((uint32_t)k[3])<<16); - c += k[4] + (((uint32_t)k[5])<<16); - mix(a,b,c); - length -= 12; - k += 6; - } + while ( length > 12 ) { + a += k[0] + ( ( ( uint32_t ) k[1] ) << 16 ); + b += k[2] + ( ( ( uint32_t ) k[3] ) << 16 ); + c += k[4] + ( ( ( uint32_t ) k[5] ) << 16 ); + mix( a, b, c ); + length -= 12; + k += 6; + } /*----------------------------- handle the last (probably partial) block */ - k8 = (const uint8_t *)k; - switch(length) - { - case 12: c+=k[4]+(((uint32_t)k[5])<<16); - b+=k[2]+(((uint32_t)k[3])<<16); - a+=k[0]+(((uint32_t)k[1])<<16); - break; - case 11: c+=((uint32_t)k8[10])<<16; /* fall through */ - case 10: c+=k[4]; - b+=k[2]+(((uint32_t)k[3])<<16); - a+=k[0]+(((uint32_t)k[1])<<16); - break; - case 9 : c+=k8[8]; /* fall through */ - case 8 : b+=k[2]+(((uint32_t)k[3])<<16); - a+=k[0]+(((uint32_t)k[1])<<16); - break; - case 7 : b+=((uint32_t)k8[6])<<16; /* fall through */ - case 6 : b+=k[2]; - a+=k[0]+(((uint32_t)k[1])<<16); - break; - case 5 : b+=k8[4]; /* fall through */ - case 4 : a+=k[0]+(((uint32_t)k[1])<<16); - break; - case 3 : a+=((uint32_t)k8[2])<<16; /* fall through */ - case 2 : a+=k[0]; - break; - case 1 : a+=k8[0]; - break; - case 0 : return c; /* zero length requires no mixing */ - } + k8 = ( const uint8_t * ) k; + switch ( length ) { + case 12: + c += k[4] + ( ( ( uint32_t ) k[5] ) << 16 ); + b += k[2] + ( ( ( uint32_t ) k[3] ) << 16 ); + a += k[0] + ( ( ( uint32_t ) k[1] ) << 16 ); + break; + case 11: + c += ( ( uint32_t ) k8[10] ) << 16; /* fall through */ + case 10: + c += k[4]; + b += k[2] + ( ( ( uint32_t ) k[3] ) << 16 ); + a += k[0] + ( ( ( uint32_t ) k[1] ) << 16 ); + break; + case 9: + c += k8[8]; /* fall through */ + case 8: + b += k[2] + ( ( ( uint32_t ) k[3] ) << 16 ); + a += k[0] + ( ( ( uint32_t ) k[1] ) << 16 ); + break; + case 7: + b += ( ( uint32_t ) k8[6] ) << 16; /* fall through */ + case 6: + b += k[2]; + a += k[0] + ( ( ( uint32_t ) k[1] ) << 16 ); + break; + case 5: + b += k8[4]; /* fall through */ + case 4: + a += k[0] + ( ( ( uint32_t ) k[1] ) << 16 ); + break; + case 3: + a += ( ( uint32_t ) k8[2] ) << 16; /* fall through */ + case 2: + a += k[0]; + break; + case 1: + a += k8[0]; + break; + case 0: + return c; /* zero length requires no mixing */ + } - } else { /* need to read the key one byte at a time */ - const uint8_t *k = (const uint8_t *)key; + } else { /* need to read the key one byte at a time */ + const uint8_t *k = ( const uint8_t * ) key; /*--------------- all but the last block: affect some 32 bits of (a,b,c) */ - while (length > 12) - { - a += k[0]; - a += ((uint32_t)k[1])<<8; - a += ((uint32_t)k[2])<<16; - a += ((uint32_t)k[3])<<24; - b += k[4]; - b += ((uint32_t)k[5])<<8; - b += ((uint32_t)k[6])<<16; - b += ((uint32_t)k[7])<<24; - c += k[8]; - c += ((uint32_t)k[9])<<8; - c += ((uint32_t)k[10])<<16; - c += ((uint32_t)k[11])<<24; - mix(a,b,c); - length -= 12; - k += 12; - } + while ( length > 12 ) { + a += k[0]; + a += ( ( uint32_t ) k[1] ) << 8; + a += ( ( uint32_t ) k[2] ) << 16; + a += ( ( uint32_t ) k[3] ) << 24; + b += k[4]; + b += ( ( uint32_t ) k[5] ) << 8; + b += ( ( uint32_t ) k[6] ) << 16; + b += ( ( uint32_t ) k[7] ) << 24; + c += k[8]; + c += ( ( uint32_t ) k[9] ) << 8; + c += ( ( uint32_t ) k[10] ) << 16; + c += ( ( uint32_t ) k[11] ) << 24; + mix( a, b, c ); + length -= 12; + k += 12; + } /*-------------------------------- last block: affect all 32 bits of (c) */ - switch(length) /* all the case statements fall through */ - { - case 12: c+=((uint32_t)k[11])<<24; - case 11: c+=((uint32_t)k[10])<<16; - case 10: c+=((uint32_t)k[9])<<8; - case 9 : c+=k[8]; - case 8 : b+=((uint32_t)k[7])<<24; - case 7 : b+=((uint32_t)k[6])<<16; - case 6 : b+=((uint32_t)k[5])<<8; - case 5 : b+=k[4]; - case 4 : a+=((uint32_t)k[3])<<24; - case 3 : a+=((uint32_t)k[2])<<16; - case 2 : a+=((uint32_t)k[1])<<8; - case 1 : a+=k[0]; - break; - case 0 : return c; + switch ( length ) { /* all the case statements fall through */ + case 12: + c += ( ( uint32_t ) k[11] ) << 24; + case 11: + c += ( ( uint32_t ) k[10] ) << 16; + case 10: + c += ( ( uint32_t ) k[9] ) << 8; + case 9: + c += k[8]; + case 8: + b += ( ( uint32_t ) k[7] ) << 24; + case 7: + b += ( ( uint32_t ) k[6] ) << 16; + case 6: + b += ( ( uint32_t ) k[5] ) << 8; + case 5: + b += k[4]; + case 4: + a += ( ( uint32_t ) k[3] ) << 24; + case 3: + a += ( ( uint32_t ) k[2] ) << 16; + case 2: + a += ( ( uint32_t ) k[1] ) << 8; + case 1: + a += k[0]; + break; + case 0: + return c; + } } - } - final(a,b,c); - return c; + final( a, b, c ); + return c; } @@ -459,178 +536,264 @@ uint32_t hashlittle( const void *key, size_t length, uint32_t initval) * the key. *pc is better mixed than *pb, so use *pc first. If you want * a 64-bit value do something like "*pc + (((uint64_t)*pb)<<32)". */ -void hashlittle2( - const void *key, /* the key to hash */ - size_t length, /* length of the key */ - uint32_t *pc, /* IN: primary initval, OUT: primary hash */ - uint32_t *pb) /* IN: secondary initval, OUT: secondary hash */ -{ - uint32_t a,b,c; /* internal state */ - union { const void *ptr; size_t i; } u; /* needed for Mac Powerbook G4 */ +void hashlittle2( const void *key, /* the key to hash */ + size_t length, /* length of the key */ + uint32_t * pc, /* IN: primary initval, OUT: primary hash */ + uint32_t * pb ) { /* IN: secondary initval, OUT: secondary hash */ + uint32_t a, b, c; /* internal state */ + union { + const void *ptr; + size_t i; + } u; /* needed for Mac Powerbook G4 */ - /* Set up the internal state */ - a = b = c = 0xdeadbeef + ((uint32_t)length) + *pc; - c += *pb; + /* Set up the internal state */ + a = b = c = 0xdeadbeef + ( ( uint32_t ) length ) + *pc; + c += *pb; - u.ptr = key; - if (HASH_LITTLE_ENDIAN && ((u.i & 0x3) == 0)) { - const uint32_t *k = (const uint32_t *)key; /* read 32-bit chunks */ - const uint8_t *k8; + u.ptr = key; + if ( HASH_LITTLE_ENDIAN && ( ( u.i & 0x3 ) == 0 ) ) { + const uint32_t *k = ( const uint32_t * ) key; /* read 32-bit chunks */ + const uint8_t *k8; /*------ all but last block: aligned reads and affect 32 bits of (a,b,c) */ - while (length > 12) - { - a += k[0]; - b += k[1]; - c += k[2]; - mix(a,b,c); - length -= 12; - k += 3; - } + while ( length > 12 ) { + a += k[0]; + b += k[1]; + c += k[2]; + mix( a, b, c ); + length -= 12; + k += 3; + } /*----------------------------- handle the last (probably partial) block */ - /* - * "k[2]&0xffffff" actually reads beyond the end of the string, but - * then masks off the part it's not allowed to read. Because the - * string is aligned, the masked-off tail is in the same word as the - * rest of the string. Every machine with memory protection I've seen - * does it on word boundaries, so is OK with this. But VALGRIND will - * still catch it and complain. The masking trick does make the hash - * noticably faster for short strings (like English words). - */ + /* + * "k[2]&0xffffff" actually reads beyond the end of the string, but + * then masks off the part it's not allowed to read. Because the + * string is aligned, the masked-off tail is in the same word as the + * rest of the string. Every machine with memory protection I've seen + * does it on word boundaries, so is OK with this. But VALGRIND will + * still catch it and complain. The masking trick does make the hash + * noticably faster for short strings (like English words). + */ #ifndef VALGRIND - switch(length) - { - case 12: c+=k[2]; b+=k[1]; a+=k[0]; break; - case 11: c+=k[2]&0xffffff; b+=k[1]; a+=k[0]; break; - case 10: c+=k[2]&0xffff; b+=k[1]; a+=k[0]; break; - case 9 : c+=k[2]&0xff; b+=k[1]; a+=k[0]; break; - case 8 : b+=k[1]; a+=k[0]; break; - case 7 : b+=k[1]&0xffffff; a+=k[0]; break; - case 6 : b+=k[1]&0xffff; a+=k[0]; break; - case 5 : b+=k[1]&0xff; a+=k[0]; break; - case 4 : a+=k[0]; break; - case 3 : a+=k[0]&0xffffff; break; - case 2 : a+=k[0]&0xffff; break; - case 1 : a+=k[0]&0xff; break; - case 0 : *pc=c; *pb=b; return; /* zero length strings require no mixing */ - } + switch ( length ) { + case 12: + c += k[2]; + b += k[1]; + a += k[0]; + break; + case 11: + c += k[2] & 0xffffff; + b += k[1]; + a += k[0]; + break; + case 10: + c += k[2] & 0xffff; + b += k[1]; + a += k[0]; + break; + case 9: + c += k[2] & 0xff; + b += k[1]; + a += k[0]; + break; + case 8: + b += k[1]; + a += k[0]; + break; + case 7: + b += k[1] & 0xffffff; + a += k[0]; + break; + case 6: + b += k[1] & 0xffff; + a += k[0]; + break; + case 5: + b += k[1] & 0xff; + a += k[0]; + break; + case 4: + a += k[0]; + break; + case 3: + a += k[0] & 0xffffff; + break; + case 2: + a += k[0] & 0xffff; + break; + case 1: + a += k[0] & 0xff; + break; + case 0: + *pc = c; + *pb = b; + return; /* zero length strings require no mixing */ + } #else /* make valgrind happy */ - k8 = (const uint8_t *)k; - switch(length) - { - case 12: c+=k[2]; b+=k[1]; a+=k[0]; break; - case 11: c+=((uint32_t)k8[10])<<16; /* fall through */ - case 10: c+=((uint32_t)k8[9])<<8; /* fall through */ - case 9 : c+=k8[8]; /* fall through */ - case 8 : b+=k[1]; a+=k[0]; break; - case 7 : b+=((uint32_t)k8[6])<<16; /* fall through */ - case 6 : b+=((uint32_t)k8[5])<<8; /* fall through */ - case 5 : b+=k8[4]; /* fall through */ - case 4 : a+=k[0]; break; - case 3 : a+=((uint32_t)k8[2])<<16; /* fall through */ - case 2 : a+=((uint32_t)k8[1])<<8; /* fall through */ - case 1 : a+=k8[0]; break; - case 0 : *pc=c; *pb=b; return; /* zero length strings require no mixing */ - } + k8 = ( const uint8_t * ) k; + switch ( length ) { + case 12: + c += k[2]; + b += k[1]; + a += k[0]; + break; + case 11: + c += ( ( uint32_t ) k8[10] ) << 16; /* fall through */ + case 10: + c += ( ( uint32_t ) k8[9] ) << 8; /* fall through */ + case 9: + c += k8[8]; /* fall through */ + case 8: + b += k[1]; + a += k[0]; + break; + case 7: + b += ( ( uint32_t ) k8[6] ) << 16; /* fall through */ + case 6: + b += ( ( uint32_t ) k8[5] ) << 8; /* fall through */ + case 5: + b += k8[4]; /* fall through */ + case 4: + a += k[0]; + break; + case 3: + a += ( ( uint32_t ) k8[2] ) << 16; /* fall through */ + case 2: + a += ( ( uint32_t ) k8[1] ) << 8; /* fall through */ + case 1: + a += k8[0]; + break; + case 0: + *pc = c; + *pb = b; + return; /* zero length strings require no mixing */ + } #endif /* !valgrind */ - } else if (HASH_LITTLE_ENDIAN && ((u.i & 0x1) == 0)) { - const uint16_t *k = (const uint16_t *)key; /* read 16-bit chunks */ - const uint8_t *k8; + } else if ( HASH_LITTLE_ENDIAN && ( ( u.i & 0x1 ) == 0 ) ) { + const uint16_t *k = ( const uint16_t * ) key; /* read 16-bit chunks */ + const uint8_t *k8; /*--------------- all but last block: aligned reads and different mixing */ - while (length > 12) - { - a += k[0] + (((uint32_t)k[1])<<16); - b += k[2] + (((uint32_t)k[3])<<16); - c += k[4] + (((uint32_t)k[5])<<16); - mix(a,b,c); - length -= 12; - k += 6; - } + while ( length > 12 ) { + a += k[0] + ( ( ( uint32_t ) k[1] ) << 16 ); + b += k[2] + ( ( ( uint32_t ) k[3] ) << 16 ); + c += k[4] + ( ( ( uint32_t ) k[5] ) << 16 ); + mix( a, b, c ); + length -= 12; + k += 6; + } /*----------------------------- handle the last (probably partial) block */ - k8 = (const uint8_t *)k; - switch(length) - { - case 12: c+=k[4]+(((uint32_t)k[5])<<16); - b+=k[2]+(((uint32_t)k[3])<<16); - a+=k[0]+(((uint32_t)k[1])<<16); - break; - case 11: c+=((uint32_t)k8[10])<<16; /* fall through */ - case 10: c+=k[4]; - b+=k[2]+(((uint32_t)k[3])<<16); - a+=k[0]+(((uint32_t)k[1])<<16); - break; - case 9 : c+=k8[8]; /* fall through */ - case 8 : b+=k[2]+(((uint32_t)k[3])<<16); - a+=k[0]+(((uint32_t)k[1])<<16); - break; - case 7 : b+=((uint32_t)k8[6])<<16; /* fall through */ - case 6 : b+=k[2]; - a+=k[0]+(((uint32_t)k[1])<<16); - break; - case 5 : b+=k8[4]; /* fall through */ - case 4 : a+=k[0]+(((uint32_t)k[1])<<16); - break; - case 3 : a+=((uint32_t)k8[2])<<16; /* fall through */ - case 2 : a+=k[0]; - break; - case 1 : a+=k8[0]; - break; - case 0 : *pc=c; *pb=b; return; /* zero length strings require no mixing */ - } + k8 = ( const uint8_t * ) k; + switch ( length ) { + case 12: + c += k[4] + ( ( ( uint32_t ) k[5] ) << 16 ); + b += k[2] + ( ( ( uint32_t ) k[3] ) << 16 ); + a += k[0] + ( ( ( uint32_t ) k[1] ) << 16 ); + break; + case 11: + c += ( ( uint32_t ) k8[10] ) << 16; /* fall through */ + case 10: + c += k[4]; + b += k[2] + ( ( ( uint32_t ) k[3] ) << 16 ); + a += k[0] + ( ( ( uint32_t ) k[1] ) << 16 ); + break; + case 9: + c += k8[8]; /* fall through */ + case 8: + b += k[2] + ( ( ( uint32_t ) k[3] ) << 16 ); + a += k[0] + ( ( ( uint32_t ) k[1] ) << 16 ); + break; + case 7: + b += ( ( uint32_t ) k8[6] ) << 16; /* fall through */ + case 6: + b += k[2]; + a += k[0] + ( ( ( uint32_t ) k[1] ) << 16 ); + break; + case 5: + b += k8[4]; /* fall through */ + case 4: + a += k[0] + ( ( ( uint32_t ) k[1] ) << 16 ); + break; + case 3: + a += ( ( uint32_t ) k8[2] ) << 16; /* fall through */ + case 2: + a += k[0]; + break; + case 1: + a += k8[0]; + break; + case 0: + *pc = c; + *pb = b; + return; /* zero length strings require no mixing */ + } - } else { /* need to read the key one byte at a time */ - const uint8_t *k = (const uint8_t *)key; + } else { /* need to read the key one byte at a time */ + const uint8_t *k = ( const uint8_t * ) key; /*--------------- all but the last block: affect some 32 bits of (a,b,c) */ - while (length > 12) - { - a += k[0]; - a += ((uint32_t)k[1])<<8; - a += ((uint32_t)k[2])<<16; - a += ((uint32_t)k[3])<<24; - b += k[4]; - b += ((uint32_t)k[5])<<8; - b += ((uint32_t)k[6])<<16; - b += ((uint32_t)k[7])<<24; - c += k[8]; - c += ((uint32_t)k[9])<<8; - c += ((uint32_t)k[10])<<16; - c += ((uint32_t)k[11])<<24; - mix(a,b,c); - length -= 12; - k += 12; - } + while ( length > 12 ) { + a += k[0]; + a += ( ( uint32_t ) k[1] ) << 8; + a += ( ( uint32_t ) k[2] ) << 16; + a += ( ( uint32_t ) k[3] ) << 24; + b += k[4]; + b += ( ( uint32_t ) k[5] ) << 8; + b += ( ( uint32_t ) k[6] ) << 16; + b += ( ( uint32_t ) k[7] ) << 24; + c += k[8]; + c += ( ( uint32_t ) k[9] ) << 8; + c += ( ( uint32_t ) k[10] ) << 16; + c += ( ( uint32_t ) k[11] ) << 24; + mix( a, b, c ); + length -= 12; + k += 12; + } /*-------------------------------- last block: affect all 32 bits of (c) */ - switch(length) /* all the case statements fall through */ - { - case 12: c+=((uint32_t)k[11])<<24; - case 11: c+=((uint32_t)k[10])<<16; - case 10: c+=((uint32_t)k[9])<<8; - case 9 : c+=k[8]; - case 8 : b+=((uint32_t)k[7])<<24; - case 7 : b+=((uint32_t)k[6])<<16; - case 6 : b+=((uint32_t)k[5])<<8; - case 5 : b+=k[4]; - case 4 : a+=((uint32_t)k[3])<<24; - case 3 : a+=((uint32_t)k[2])<<16; - case 2 : a+=((uint32_t)k[1])<<8; - case 1 : a+=k[0]; - break; - case 0 : *pc=c; *pb=b; return; /* zero length strings require no mixing */ + switch ( length ) { /* all the case statements fall through */ + case 12: + c += ( ( uint32_t ) k[11] ) << 24; + case 11: + c += ( ( uint32_t ) k[10] ) << 16; + case 10: + c += ( ( uint32_t ) k[9] ) << 8; + case 9: + c += k[8]; + case 8: + b += ( ( uint32_t ) k[7] ) << 24; + case 7: + b += ( ( uint32_t ) k[6] ) << 16; + case 6: + b += ( ( uint32_t ) k[5] ) << 8; + case 5: + b += k[4]; + case 4: + a += ( ( uint32_t ) k[3] ) << 24; + case 3: + a += ( ( uint32_t ) k[2] ) << 16; + case 2: + a += ( ( uint32_t ) k[1] ) << 8; + case 1: + a += k[0]; + break; + case 0: + *pc = c; + *pb = b; + return; /* zero length strings require no mixing */ + } } - } - final(a,b,c); - *pc=c; *pb=b; + final( a, b, c ); + *pc = c; + *pb = b; } @@ -641,147 +804,214 @@ void hashlittle2( * from hashlittle() on all machines. hashbig() takes advantage of * big-endian byte ordering. */ -uint32_t hashbig( const void *key, size_t length, uint32_t initval) -{ - uint32_t a,b,c; - union { const void *ptr; size_t i; } u; /* to cast key to (size_t) happily */ +uint32_t hashbig( const void *key, size_t length, uint32_t initval ) { + uint32_t a, b, c; + union { + const void *ptr; + size_t i; + } u; /* to cast key to (size_t) happily */ - /* Set up the internal state */ - a = b = c = 0xdeadbeef + ((uint32_t)length) + initval; + /* Set up the internal state */ + a = b = c = 0xdeadbeef + ( ( uint32_t ) length ) + initval; - u.ptr = key; - if (HASH_BIG_ENDIAN && ((u.i & 0x3) == 0)) { - const uint32_t *k = (const uint32_t *)key; /* read 32-bit chunks */ - const uint8_t *k8; + u.ptr = key; + if ( HASH_BIG_ENDIAN && ( ( u.i & 0x3 ) == 0 ) ) { + const uint32_t *k = ( const uint32_t * ) key; /* read 32-bit chunks */ + const uint8_t *k8; /*------ all but last block: aligned reads and affect 32 bits of (a,b,c) */ - while (length > 12) - { - a += k[0]; - b += k[1]; - c += k[2]; - mix(a,b,c); - length -= 12; - k += 3; - } + while ( length > 12 ) { + a += k[0]; + b += k[1]; + c += k[2]; + mix( a, b, c ); + length -= 12; + k += 3; + } /*----------------------------- handle the last (probably partial) block */ - /* - * "k[2]<<8" actually reads beyond the end of the string, but - * then shifts out the part it's not allowed to read. Because the - * string is aligned, the illegal read is in the same word as the - * rest of the string. Every machine with memory protection I've seen - * does it on word boundaries, so is OK with this. But VALGRIND will - * still catch it and complain. The masking trick does make the hash - * noticably faster for short strings (like English words). - */ + /* + * "k[2]<<8" actually reads beyond the end of the string, but + * then shifts out the part it's not allowed to read. Because the + * string is aligned, the illegal read is in the same word as the + * rest of the string. Every machine with memory protection I've seen + * does it on word boundaries, so is OK with this. But VALGRIND will + * still catch it and complain. The masking trick does make the hash + * noticably faster for short strings (like English words). + */ #ifndef VALGRIND - switch(length) - { - case 12: c+=k[2]; b+=k[1]; a+=k[0]; break; - case 11: c+=k[2]&0xffffff00; b+=k[1]; a+=k[0]; break; - case 10: c+=k[2]&0xffff0000; b+=k[1]; a+=k[0]; break; - case 9 : c+=k[2]&0xff000000; b+=k[1]; a+=k[0]; break; - case 8 : b+=k[1]; a+=k[0]; break; - case 7 : b+=k[1]&0xffffff00; a+=k[0]; break; - case 6 : b+=k[1]&0xffff0000; a+=k[0]; break; - case 5 : b+=k[1]&0xff000000; a+=k[0]; break; - case 4 : a+=k[0]; break; - case 3 : a+=k[0]&0xffffff00; break; - case 2 : a+=k[0]&0xffff0000; break; - case 1 : a+=k[0]&0xff000000; break; - case 0 : return c; /* zero length strings require no mixing */ - } + switch ( length ) { + case 12: + c += k[2]; + b += k[1]; + a += k[0]; + break; + case 11: + c += k[2] & 0xffffff00; + b += k[1]; + a += k[0]; + break; + case 10: + c += k[2] & 0xffff0000; + b += k[1]; + a += k[0]; + break; + case 9: + c += k[2] & 0xff000000; + b += k[1]; + a += k[0]; + break; + case 8: + b += k[1]; + a += k[0]; + break; + case 7: + b += k[1] & 0xffffff00; + a += k[0]; + break; + case 6: + b += k[1] & 0xffff0000; + a += k[0]; + break; + case 5: + b += k[1] & 0xff000000; + a += k[0]; + break; + case 4: + a += k[0]; + break; + case 3: + a += k[0] & 0xffffff00; + break; + case 2: + a += k[0] & 0xffff0000; + break; + case 1: + a += k[0] & 0xff000000; + break; + case 0: + return c; /* zero length strings require no mixing */ + } -#else /* make valgrind happy */ +#else /* make valgrind happy */ - k8 = (const uint8_t *)k; - switch(length) /* all the case statements fall through */ - { - case 12: c+=k[2]; b+=k[1]; a+=k[0]; break; - case 11: c+=((uint32_t)k8[10])<<8; /* fall through */ - case 10: c+=((uint32_t)k8[9])<<16; /* fall through */ - case 9 : c+=((uint32_t)k8[8])<<24; /* fall through */ - case 8 : b+=k[1]; a+=k[0]; break; - case 7 : b+=((uint32_t)k8[6])<<8; /* fall through */ - case 6 : b+=((uint32_t)k8[5])<<16; /* fall through */ - case 5 : b+=((uint32_t)k8[4])<<24; /* fall through */ - case 4 : a+=k[0]; break; - case 3 : a+=((uint32_t)k8[2])<<8; /* fall through */ - case 2 : a+=((uint32_t)k8[1])<<16; /* fall through */ - case 1 : a+=((uint32_t)k8[0])<<24; break; - case 0 : return c; - } + k8 = ( const uint8_t * ) k; + switch ( length ) { /* all the case statements fall through */ + case 12: + c += k[2]; + b += k[1]; + a += k[0]; + break; + case 11: + c += ( ( uint32_t ) k8[10] ) << 8; /* fall through */ + case 10: + c += ( ( uint32_t ) k8[9] ) << 16; /* fall through */ + case 9: + c += ( ( uint32_t ) k8[8] ) << 24; /* fall through */ + case 8: + b += k[1]; + a += k[0]; + break; + case 7: + b += ( ( uint32_t ) k8[6] ) << 8; /* fall through */ + case 6: + b += ( ( uint32_t ) k8[5] ) << 16; /* fall through */ + case 5: + b += ( ( uint32_t ) k8[4] ) << 24; /* fall through */ + case 4: + a += k[0]; + break; + case 3: + a += ( ( uint32_t ) k8[2] ) << 8; /* fall through */ + case 2: + a += ( ( uint32_t ) k8[1] ) << 16; /* fall through */ + case 1: + a += ( ( uint32_t ) k8[0] ) << 24; + break; + case 0: + return c; + } #endif /* !VALGRIND */ - } else { /* need to read the key one byte at a time */ - const uint8_t *k = (const uint8_t *)key; + } else { /* need to read the key one byte at a time */ + const uint8_t *k = ( const uint8_t * ) key; /*--------------- all but the last block: affect some 32 bits of (a,b,c) */ - while (length > 12) - { - a += ((uint32_t)k[0])<<24; - a += ((uint32_t)k[1])<<16; - a += ((uint32_t)k[2])<<8; - a += ((uint32_t)k[3]); - b += ((uint32_t)k[4])<<24; - b += ((uint32_t)k[5])<<16; - b += ((uint32_t)k[6])<<8; - b += ((uint32_t)k[7]); - c += ((uint32_t)k[8])<<24; - c += ((uint32_t)k[9])<<16; - c += ((uint32_t)k[10])<<8; - c += ((uint32_t)k[11]); - mix(a,b,c); - length -= 12; - k += 12; - } + while ( length > 12 ) { + a += ( ( uint32_t ) k[0] ) << 24; + a += ( ( uint32_t ) k[1] ) << 16; + a += ( ( uint32_t ) k[2] ) << 8; + a += ( ( uint32_t ) k[3] ); + b += ( ( uint32_t ) k[4] ) << 24; + b += ( ( uint32_t ) k[5] ) << 16; + b += ( ( uint32_t ) k[6] ) << 8; + b += ( ( uint32_t ) k[7] ); + c += ( ( uint32_t ) k[8] ) << 24; + c += ( ( uint32_t ) k[9] ) << 16; + c += ( ( uint32_t ) k[10] ) << 8; + c += ( ( uint32_t ) k[11] ); + mix( a, b, c ); + length -= 12; + k += 12; + } /*-------------------------------- last block: affect all 32 bits of (c) */ - switch(length) /* all the case statements fall through */ - { - case 12: c+=k[11]; - case 11: c+=((uint32_t)k[10])<<8; - case 10: c+=((uint32_t)k[9])<<16; - case 9 : c+=((uint32_t)k[8])<<24; - case 8 : b+=k[7]; - case 7 : b+=((uint32_t)k[6])<<8; - case 6 : b+=((uint32_t)k[5])<<16; - case 5 : b+=((uint32_t)k[4])<<24; - case 4 : a+=k[3]; - case 3 : a+=((uint32_t)k[2])<<8; - case 2 : a+=((uint32_t)k[1])<<16; - case 1 : a+=((uint32_t)k[0])<<24; - break; - case 0 : return c; + switch ( length ) { /* all the case statements fall through */ + case 12: + c += k[11]; + case 11: + c += ( ( uint32_t ) k[10] ) << 8; + case 10: + c += ( ( uint32_t ) k[9] ) << 16; + case 9: + c += ( ( uint32_t ) k[8] ) << 24; + case 8: + b += k[7]; + case 7: + b += ( ( uint32_t ) k[6] ) << 8; + case 6: + b += ( ( uint32_t ) k[5] ) << 16; + case 5: + b += ( ( uint32_t ) k[4] ) << 24; + case 4: + a += k[3]; + case 3: + a += ( ( uint32_t ) k[2] ) << 8; + case 2: + a += ( ( uint32_t ) k[1] ) << 16; + case 1: + a += ( ( uint32_t ) k[0] ) << 24; + break; + case 0: + return c; + } } - } - final(a,b,c); - return c; + final( a, b, c ); + return c; } #ifdef SELF_TEST /* used for timings */ -void driver1() -{ - uint8_t buf[256]; - uint32_t i; - uint32_t h=0; - time_t a,z; +void driver1( ) { + uint8_t buf[256]; + uint32_t i; + uint32_t h = 0; + time_t a, z; - time(&a); - for (i=0; i<256; ++i) buf[i] = 'x'; - for (i=0; i<1; ++i) - { - h = hashlittle(&buf[0],1,h); - } - time(&z); - if (z-a > 0) printf("time %d %.8x\n", z-a, h); + time( &a ); + for ( i = 0; i < 256; ++i ) + buf[i] = 'x'; + for ( i = 0; i < 1; ++i ) { + h = hashlittle( &buf[0], 1, h ); + } + time( &z ); + if ( z - a > 0 ) + printf( "time %d %.8x\n", z - a, h ); } /* check that every input bit changes every output bit half the time */ @@ -789,213 +1019,263 @@ void driver1() #define HASHLEN 1 #define MAXPAIR 60 #define MAXLEN 70 -void driver2() -{ - uint8_t qa[MAXLEN+1], qb[MAXLEN+2], *a = &qa[0], *b = &qb[1]; - uint32_t c[HASHSTATE], d[HASHSTATE], i=0, j=0, k, l, m=0, z; - uint32_t e[HASHSTATE],f[HASHSTATE],g[HASHSTATE],h[HASHSTATE]; - uint32_t x[HASHSTATE],y[HASHSTATE]; - uint32_t hlen; +void driver2( ) { + uint8_t qa[MAXLEN + 1], qb[MAXLEN + 2], *a = &qa[0], *b = &qb[1]; + uint32_t c[HASHSTATE], d[HASHSTATE], i = 0, j = 0, k, l, m = 0, z; + uint32_t e[HASHSTATE], f[HASHSTATE], g[HASHSTATE], h[HASHSTATE]; + uint32_t x[HASHSTATE], y[HASHSTATE]; + uint32_t hlen; - printf("No more than %d trials should ever be needed \n",MAXPAIR/2); - for (hlen=0; hlen < MAXLEN; ++hlen) - { - z=0; - for (i=0; i>(8-j)); - c[0] = hashlittle(a, hlen, m); - b[i] ^= ((k+1)<>(8-j)); - d[0] = hashlittle(b, hlen, m); - /* check every bit is 1, 0, set, and not set at least once */ - for (l=0; lz) z=k; - if (k==MAXPAIR) - { - printf("Some bit didn't change: "); - printf("%.8x %.8x %.8x %.8x %.8x %.8x ", - e[0],f[0],g[0],h[0],x[0],y[0]); - printf("i %d j %d m %d len %d\n", i, j, m, hlen); - } - if (z==MAXPAIR) goto done; - } - } + /*---- check that every output bit is affected by that input bit */ + for ( k = 0; k < MAXPAIR; k += 2 ) { + uint32_t finished = 1; + /* keys have one bit different */ + for ( l = 0; l < hlen + 1; ++l ) { + a[l] = b[l] = ( uint8_t ) 0; + } + /* have a and b be two keys differing in only one bit */ + a[i] ^= ( k << j ); + a[i] ^= ( k >> ( 8 - j ) ); + c[0] = hashlittle( a, hlen, m ); + b[i] ^= ( ( k + 1 ) << j ); + b[i] ^= ( ( k + 1 ) >> ( 8 - j ) ); + d[0] = hashlittle( b, hlen, m ); + /* check every bit is 1, 0, set, and not set at least once */ + for ( l = 0; l < HASHSTATE; ++l ) { + e[l] &= ( c[l] ^ d[l] ); + f[l] &= ~( c[l] ^ d[l] ); + g[l] &= c[l]; + h[l] &= ~c[l]; + x[l] &= d[l]; + y[l] &= ~d[l]; + if ( e[l] | f[l] | g[l] | h[l] | x[l] | y[l] ) + finished = 0; + } + if ( finished ) + break; + } + if ( k > z ) + z = k; + if ( k == MAXPAIR ) { + printf( "Some bit didn't change: " ); + printf( "%.8x %.8x %.8x %.8x %.8x %.8x ", + e[0], f[0], g[0], h[0], x[0], y[0] ); + printf( "i %d j %d m %d len %d\n", i, j, m, hlen ); + } + if ( z == MAXPAIR ) + goto done; + } + } + } + done: + if ( z < MAXPAIR ) { + printf( "Mix success %2d bytes %2d initvals ", i, m ); + printf( "required %d trials\n", z / 2 ); + } } - done: - if (z < MAXPAIR) - { - printf("Mix success %2d bytes %2d initvals ",i,m); - printf("required %d trials\n", z/2); - } - } - printf("\n"); + printf( "\n" ); } /* Check for reading beyond the end of the buffer and alignment problems */ -void driver3() -{ - uint8_t buf[MAXLEN+20], *b; - uint32_t len; - uint8_t q[] = "This is the time for all good men to come to the aid of their country..."; - uint32_t h; - uint8_t qq[] = "xThis is the time for all good men to come to the aid of their country..."; - uint32_t i; - uint8_t qqq[] = "xxThis is the time for all good men to come to the aid of their country..."; - uint32_t j; - uint8_t qqqq[] = "xxxThis is the time for all good men to come to the aid of their country..."; - uint32_t ref,x,y; - uint8_t *p; +void driver3( ) { + uint8_t buf[MAXLEN + 20], *b; + uint32_t len; + uint8_t q[] = + "This is the time for all good men to come to the aid of their country..."; + uint32_t h; + uint8_t qq[] = + "xThis is the time for all good men to come to the aid of their country..."; + uint32_t i; + uint8_t qqq[] = + "xxThis is the time for all good men to come to the aid of their country..."; + uint32_t j; + uint8_t qqqq[] = + "xxxThis is the time for all good men to come to the aid of their country..."; + uint32_t ref, x, y; + uint8_t *p; - printf("Endianness. These lines should all be the same (for values filled in):\n"); - printf("%.8x %.8x %.8x\n", - hashword((const uint32_t *)q, (sizeof(q)-1)/4, 13), - hashword((const uint32_t *)q, (sizeof(q)-5)/4, 13), - hashword((const uint32_t *)q, (sizeof(q)-9)/4, 13)); - p = q; - printf("%.8x %.8x %.8x %.8x %.8x %.8x %.8x %.8x %.8x %.8x %.8x %.8x\n", - hashlittle(p, sizeof(q)-1, 13), hashlittle(p, sizeof(q)-2, 13), - hashlittle(p, sizeof(q)-3, 13), hashlittle(p, sizeof(q)-4, 13), - hashlittle(p, sizeof(q)-5, 13), hashlittle(p, sizeof(q)-6, 13), - hashlittle(p, sizeof(q)-7, 13), hashlittle(p, sizeof(q)-8, 13), - hashlittle(p, sizeof(q)-9, 13), hashlittle(p, sizeof(q)-10, 13), - hashlittle(p, sizeof(q)-11, 13), hashlittle(p, sizeof(q)-12, 13)); - p = &qq[1]; - printf("%.8x %.8x %.8x %.8x %.8x %.8x %.8x %.8x %.8x %.8x %.8x %.8x\n", - hashlittle(p, sizeof(q)-1, 13), hashlittle(p, sizeof(q)-2, 13), - hashlittle(p, sizeof(q)-3, 13), hashlittle(p, sizeof(q)-4, 13), - hashlittle(p, sizeof(q)-5, 13), hashlittle(p, sizeof(q)-6, 13), - hashlittle(p, sizeof(q)-7, 13), hashlittle(p, sizeof(q)-8, 13), - hashlittle(p, sizeof(q)-9, 13), hashlittle(p, sizeof(q)-10, 13), - hashlittle(p, sizeof(q)-11, 13), hashlittle(p, sizeof(q)-12, 13)); - p = &qqq[2]; - printf("%.8x %.8x %.8x %.8x %.8x %.8x %.8x %.8x %.8x %.8x %.8x %.8x\n", - hashlittle(p, sizeof(q)-1, 13), hashlittle(p, sizeof(q)-2, 13), - hashlittle(p, sizeof(q)-3, 13), hashlittle(p, sizeof(q)-4, 13), - hashlittle(p, sizeof(q)-5, 13), hashlittle(p, sizeof(q)-6, 13), - hashlittle(p, sizeof(q)-7, 13), hashlittle(p, sizeof(q)-8, 13), - hashlittle(p, sizeof(q)-9, 13), hashlittle(p, sizeof(q)-10, 13), - hashlittle(p, sizeof(q)-11, 13), hashlittle(p, sizeof(q)-12, 13)); - p = &qqqq[3]; - printf("%.8x %.8x %.8x %.8x %.8x %.8x %.8x %.8x %.8x %.8x %.8x %.8x\n", - hashlittle(p, sizeof(q)-1, 13), hashlittle(p, sizeof(q)-2, 13), - hashlittle(p, sizeof(q)-3, 13), hashlittle(p, sizeof(q)-4, 13), - hashlittle(p, sizeof(q)-5, 13), hashlittle(p, sizeof(q)-6, 13), - hashlittle(p, sizeof(q)-7, 13), hashlittle(p, sizeof(q)-8, 13), - hashlittle(p, sizeof(q)-9, 13), hashlittle(p, sizeof(q)-10, 13), - hashlittle(p, sizeof(q)-11, 13), hashlittle(p, sizeof(q)-12, 13)); - printf("\n"); + printf + ( "Endianness. These lines should all be the same (for values filled in):\n" ); + printf + ( "%.8x %.8x %.8x\n", + hashword( ( const uint32_t * ) q, ( sizeof( q ) - 1 ) / 4, 13 ), + hashword( ( const uint32_t * ) q, ( sizeof( q ) - 5 ) / 4, 13 ), + hashword( ( const uint32_t * ) q, ( sizeof( q ) - 9 ) / 4, 13 ) ); + p = q; + printf( "%.8x %.8x %.8x %.8x %.8x %.8x %.8x %.8x %.8x %.8x %.8x %.8x\n", + hashlittle( p, sizeof( q ) - 1, 13 ), hashlittle( p, + sizeof( q ) - 2, + 13 ), + hashlittle( p, sizeof( q ) - 3, 13 ), hashlittle( p, + sizeof( q ) - 4, + 13 ), + hashlittle( p, sizeof( q ) - 5, 13 ), hashlittle( p, + sizeof( q ) - 6, + 13 ), + hashlittle( p, sizeof( q ) - 7, 13 ), hashlittle( p, + sizeof( q ) - 8, + 13 ), + hashlittle( p, sizeof( q ) - 9, 13 ), hashlittle( p, + sizeof( q ) - 10, + 13 ), + hashlittle( p, sizeof( q ) - 11, 13 ), hashlittle( p, + sizeof( q ) - + 12, 13 ) ); + p = &qq[1]; + printf( "%.8x %.8x %.8x %.8x %.8x %.8x %.8x %.8x %.8x %.8x %.8x %.8x\n", + hashlittle( p, sizeof( q ) - 1, 13 ), hashlittle( p, + sizeof( q ) - 2, + 13 ), + hashlittle( p, sizeof( q ) - 3, 13 ), hashlittle( p, + sizeof( q ) - 4, + 13 ), + hashlittle( p, sizeof( q ) - 5, 13 ), hashlittle( p, + sizeof( q ) - 6, + 13 ), + hashlittle( p, sizeof( q ) - 7, 13 ), hashlittle( p, + sizeof( q ) - 8, + 13 ), + hashlittle( p, sizeof( q ) - 9, 13 ), hashlittle( p, + sizeof( q ) - 10, + 13 ), + hashlittle( p, sizeof( q ) - 11, 13 ), hashlittle( p, + sizeof( q ) - + 12, 13 ) ); + p = &qqq[2]; + printf( "%.8x %.8x %.8x %.8x %.8x %.8x %.8x %.8x %.8x %.8x %.8x %.8x\n", + hashlittle( p, sizeof( q ) - 1, 13 ), hashlittle( p, + sizeof( q ) - 2, + 13 ), + hashlittle( p, sizeof( q ) - 3, 13 ), hashlittle( p, + sizeof( q ) - 4, + 13 ), + hashlittle( p, sizeof( q ) - 5, 13 ), hashlittle( p, + sizeof( q ) - 6, + 13 ), + hashlittle( p, sizeof( q ) - 7, 13 ), hashlittle( p, + sizeof( q ) - 8, + 13 ), + hashlittle( p, sizeof( q ) - 9, 13 ), hashlittle( p, + sizeof( q ) - 10, + 13 ), + hashlittle( p, sizeof( q ) - 11, 13 ), hashlittle( p, + sizeof( q ) - + 12, 13 ) ); + p = &qqqq[3]; + printf( "%.8x %.8x %.8x %.8x %.8x %.8x %.8x %.8x %.8x %.8x %.8x %.8x\n", + hashlittle( p, sizeof( q ) - 1, 13 ), hashlittle( p, + sizeof( q ) - 2, + 13 ), + hashlittle( p, sizeof( q ) - 3, 13 ), hashlittle( p, + sizeof( q ) - 4, + 13 ), + hashlittle( p, sizeof( q ) - 5, 13 ), hashlittle( p, + sizeof( q ) - 6, + 13 ), + hashlittle( p, sizeof( q ) - 7, 13 ), hashlittle( p, + sizeof( q ) - 8, + 13 ), + hashlittle( p, sizeof( q ) - 9, 13 ), hashlittle( p, + sizeof( q ) - 10, + 13 ), + hashlittle( p, sizeof( q ) - 11, 13 ), hashlittle( p, + sizeof( q ) - + 12, 13 ) ); + printf( "\n" ); - /* check that hashlittle2 and hashlittle produce the same results */ - i=47; j=0; - hashlittle2(q, sizeof(q), &i, &j); - if (hashlittle(q, sizeof(q), 47) != i) - printf("hashlittle2 and hashlittle mismatch\n"); + /* check that hashlittle2 and hashlittle produce the same results */ + i = 47; + j = 0; + hashlittle2( q, sizeof( q ), &i, &j ); + if ( hashlittle( q, sizeof( q ), 47 ) != i ) + printf( "hashlittle2 and hashlittle mismatch\n" ); - /* check that hashword2 and hashword produce the same results */ - len = 0xdeadbeef; - i=47, j=0; - hashword2(&len, 1, &i, &j); - if (hashword(&len, 1, 47) != i) - printf("hashword2 and hashword mismatch %x %x\n", - i, hashword(&len, 1, 47)); + /* check that hashword2 and hashword produce the same results */ + len = 0xdeadbeef; + i = 47, j = 0; + hashword2( &len, 1, &i, &j ); + if ( hashword( &len, 1, 47 ) != i ) + printf( "hashword2 and hashword mismatch %x %x\n", + i, hashword( &len, 1, 47 ) ); - /* check hashlittle doesn't read before or after the ends of the string */ - for (h=0, b=buf+1; h<8; ++h, ++b) - { - for (i=0; iheader.tag.value ) { - case HASHTV: - free_hashmap( pointer ); - break; - case STACKFRAMETV: - free_stack_frame( get_stack_frame( pointer ) ); - break; - } + switch ( vso->header.tag.value ) { + case HASHTV: + free_hashmap( pointer ); + break; + case STACKFRAMETV: + free_stack_frame( get_stack_frame( pointer ) ); + break; + } // free( (void *)cell.payload.vectorp.address ); - debug_printf( DEBUG_ALLOC, L"Freed vector-space object at 0x%lx\n", - cell.payload.vectorp.address ); + debug_printf( DEBUG_ALLOC, L"Freed vector-space object at 0x%lx\n", + cell.payload.vectorp.address ); } // bool check_vso_tag( struct cons_pointer pointer, char * tag) { diff --git a/src/memory/vectorspace.h b/src/memory/vectorspace.h index 2eea84d..3265225 100644 --- a/src/memory/vectorspace.h +++ b/src/memory/vectorspace.h @@ -61,7 +61,7 @@ struct cons_pointer make_vso( uint32_t tag, uint64_t payload_size ); -void free_vso(struct cons_pointer pointer); +void free_vso( struct cons_pointer pointer ); /** * the header which forms the start of every vector space object. @@ -86,18 +86,16 @@ struct vector_space_header { * i.e. either an assoc list or a further hashmap. */ struct hashmap_payload { - struct cons_pointer - hash_fn; /* function for hashing values in this hashmap, or `NIL` to use - the default hashing function */ - struct cons_pointer write_acl; /* it seems to me that it is likely that the - * principal difference between a hashmap and a - * namespace is that a hashmap has a write ACL - * of `NIL`, meaning not writeable by anyone */ - uint32_t n_buckets; /* number of hash buckets */ - uint32_t unused; /* for word alignment and possible later expansion */ - struct cons_pointer - buckets[]; /* actual hash buckets, which should be `NIL` - * or assoc lists or (possibly) further hashmaps. */ + struct cons_pointer hash_fn; /* function for hashing values in this hashmap, or `NIL` to use + the default hashing function */ + struct cons_pointer write_acl; /* it seems to me that it is likely that the + * principal difference between a hashmap and a + * namespace is that a hashmap has a write ACL + * of `NIL`, meaning not writeable by anyone */ + uint32_t n_buckets; /* number of hash buckets */ + uint32_t unused; /* for word alignment and possible later expansion */ + struct cons_pointer buckets[]; /* actual hash buckets, which should be `NIL` + * or assoc lists or (possibly) further hashmaps. */ }; diff --git a/src/ops/equal.c b/src/ops/equal.c index feffb93..a02acc8 100644 --- a/src/ops/equal.c +++ b/src/ops/equal.c @@ -20,9 +20,8 @@ * Shallow, and thus cheap, equality: true if these two objects are * the same object, else false. */ -bool eq(struct cons_pointer a, struct cons_pointer b) -{ - return ((a.page == b.page) && (a.offset == b.offset)); +bool eq( struct cons_pointer a, struct cons_pointer b ) { + return ( ( a.page == b.page ) && ( a.offset == b.offset ) ); } /** @@ -32,10 +31,9 @@ bool eq(struct cons_pointer a, struct cons_pointer b) * @return true if the objects at these two cons pointers have the same tag, * else false. */ -bool same_type(struct cons_pointer a, struct cons_pointer b) -{ - struct cons_space_object *cell_a = &pointer2cell(a); - struct cons_space_object *cell_b = &pointer2cell(b); +bool same_type( struct cons_pointer a, struct cons_pointer b ) { + struct cons_space_object *cell_a = &pointer2cell( a ); + struct cons_space_object *cell_b = &pointer2cell( b ); return cell_a->tag.value == cell_b->tag.value; } @@ -45,104 +43,95 @@ bool same_type(struct cons_pointer a, struct cons_pointer b) * @param string the string to test * @return true if it's the end of a string. */ -bool end_of_string(struct cons_pointer string) -{ - return nilp(string) || - pointer2cell(string).payload.string.character == '\0'; +bool end_of_string( struct cons_pointer string ) { + return nilp( string ) || + pointer2cell( string ).payload.string.character == '\0'; } /** * Deep, and thus expensive, equality: true if these two objects have * identical structure, else false. */ -bool equal(struct cons_pointer a, struct cons_pointer b) -{ - bool result = eq(a, b); +bool equal( struct cons_pointer a, struct cons_pointer b ) { + bool result = eq( a, b ); - if (!result && same_type(a, b)) - { - struct cons_space_object *cell_a = &pointer2cell(a); - struct cons_space_object *cell_b = &pointer2cell(b); + if ( !result && same_type( a, b ) ) { + struct cons_space_object *cell_a = &pointer2cell( a ); + struct cons_space_object *cell_b = &pointer2cell( b ); - switch (cell_a->tag.value) - { - case CONSTV: - case LAMBDATV: - case NLAMBDATV: - /* TODO: it is not OK to do this on the stack since list-like - * structures can be of indefinite extent. It *must* be done by - * iteration (and even that is problematic) */ - result = - equal(cell_a->payload.cons.car, cell_b->payload.cons.car) && equal(cell_a->payload.cons.cdr, - cell_b->payload.cons.cdr); - break; - case KEYTV: - case STRINGTV: - case SYMBOLTV: - /* slightly complex because a string may or may not have a '\0' - * cell at the end, but I'll ignore that for now. I think in - * practice only the empty string will. - */ - /* TODO: it is not OK to do this on the stack since list-like - * structures can be of indefinite extent. It *must* be done by - * iteration (and even that is problematic) */ - result = - cell_a->payload.string.character == + switch ( cell_a->tag.value ) { + case CONSTV: + case LAMBDATV: + case NLAMBDATV: + /* TODO: it is not OK to do this on the stack since list-like + * structures can be of indefinite extent. It *must* be done by + * iteration (and even that is problematic) */ + result = + equal( cell_a->payload.cons.car, cell_b->payload.cons.car ) + && equal( cell_a->payload.cons.cdr, + cell_b->payload.cons.cdr ); + break; + case KEYTV: + case STRINGTV: + case SYMBOLTV: + /* slightly complex because a string may or may not have a '\0' + * cell at the end, but I'll ignore that for now. I think in + * practice only the empty string will. + */ + /* TODO: it is not OK to do this on the stack since list-like + * structures can be of indefinite extent. It *must* be done by + * iteration (and even that is problematic) */ + result = + cell_a->payload.string.character == cell_b->payload.string.character && - (equal(cell_a->payload.string.cdr, - cell_b->payload.string.cdr) || - (end_of_string(cell_a->payload.string.cdr) && end_of_string(cell_b->payload.string.cdr))); - break; - case INTEGERTV: - result = - (cell_a->payload.integer.value == - cell_b->payload.integer.value) && - equal(cell_a->payload.integer.more, - cell_b->payload.integer.more); - break; - case RATIOTV: - result = equal_ratio_ratio(a, b); - break; - case REALTV: - { - double num_a = to_long_double(a); - double num_b = to_long_double(b); - double max = - fabs(num_a) > - fabs(num_b) - ? fabs(num_a) - : fabs(num_b); + ( equal( cell_a->payload.string.cdr, + cell_b->payload.string.cdr ) || + ( end_of_string( cell_a->payload.string.cdr ) + && end_of_string( cell_b->payload.string.cdr ) ) ); + break; + case INTEGERTV: + result = + ( cell_a->payload.integer.value == + cell_b->payload.integer.value ) && + equal( cell_a->payload.integer.more, + cell_b->payload.integer.more ); + break; + case RATIOTV: + result = equal_ratio_ratio( a, b ); + break; + case REALTV: + { + double num_a = to_long_double( a ); + double num_b = to_long_double( b ); + double max = fabs( num_a ) > fabs( num_b ) + ? fabs( num_a ) + : fabs( num_b ); - /* - * not more different than one part in a million - close enough - */ - result = fabs(num_a - num_b) < (max / 1000000.0); + /* + * not more different than one part in a million - close enough + */ + result = fabs( num_a - num_b ) < ( max / 1000000.0 ); + } + break; + default: + result = false; + break; } - break; - default: - result = false; - break; - } - } - else if (numberp(a) && numberp(b)) - { - if (integerp(a)) - { - result = equal_integer_real(a, b); - } - else if (integerp(b)) - { - result = equal_integer_real(b, a); + } else if ( numberp( a ) && numberp( b ) ) { + if ( integerp( a ) ) { + result = equal_integer_real( a, b ); + } else if ( integerp( b ) ) { + result = equal_integer_real( b, a ); } } /* - * there's only supposed ever to be one T and one NIL cell, so each - * should be caught by eq; equality of vector-space objects is a whole - * other ball game so we won't deal with it now (and indeed may never). - * I'm not certain what equality means for read and write streams, so - * I'll ignore them, too, for now. - */ + * there's only supposed ever to be one T and one NIL cell, so each + * should be caught by eq; equality of vector-space objects is a whole + * other ball game so we won't deal with it now (and indeed may never). + * I'm not certain what equality means for read and write streams, so + * I'll ignore them, too, for now. + */ return result; } diff --git a/src/ops/intern.c b/src/ops/intern.c index 07b9693..d7b81c6 100644 --- a/src/ops/intern.c +++ b/src/ops/intern.c @@ -89,16 +89,16 @@ internedp( struct cons_pointer key, struct cons_pointer store ) { * of that key from the store; otherwise return NIL. */ struct cons_pointer c_assoc( struct cons_pointer key, - struct cons_pointer store ) { + struct cons_pointer store ) { struct cons_pointer result = NIL; - debug_print( L"c_assoc; key is `", DEBUG_BIND); - debug_print_object( key, DEBUG_BIND); - debug_print( L"`\n", DEBUG_BIND); + debug_print( L"c_assoc; key is `", DEBUG_BIND ); + debug_print_object( key, DEBUG_BIND ); + debug_print( L"`\n", DEBUG_BIND ); - if (consp(store)) { + if ( consp( store ) ) { for ( struct cons_pointer next = store; - consp( next ); next = pointer2cell( next ).payload.cons.cdr ) { + consp( next ); next = pointer2cell( next ).payload.cons.cdr ) { struct cons_space_object entry = pointer2cell( pointer2cell( next ).payload.cons.car ); @@ -107,15 +107,17 @@ struct cons_pointer c_assoc( struct cons_pointer key, break; } } - } else if (hashmapp( store)) { - result = hashmap_get( store, key); + } else if ( hashmapp( store ) ) { + result = hashmap_get( store, key ); } else { - result = throw_exception(c_string_to_lisp_string(L"Store is of unknown type"), NIL); + result = + throw_exception( c_string_to_lisp_string + ( L"Store is of unknown type" ), NIL ); } - debug_print( L"c_assoc returning ", DEBUG_BIND); - debug_print_object( result, DEBUG_BIND); - debug_println( DEBUG_BIND); + debug_print( L"c_assoc returning ", DEBUG_BIND ); + debug_print_object( result, DEBUG_BIND ); + debug_println( DEBUG_BIND ); return result; } @@ -125,8 +127,8 @@ struct cons_pointer c_assoc( struct cons_pointer key, * with this key/value pair added to the front. */ struct cons_pointer - set( struct cons_pointer key, struct cons_pointer value, - struct cons_pointer store ) { +set( struct cons_pointer key, struct cons_pointer value, + struct cons_pointer store ) { struct cons_pointer result = NIL; debug_print( L"set: binding `", DEBUG_BIND ); @@ -134,18 +136,18 @@ struct cons_pointer debug_print( L"` to `", DEBUG_BIND ); debug_print_object( value, DEBUG_BIND ); debug_print( L"` in store ", DEBUG_BIND ); - debug_dump_object( store, DEBUG_BIND); + debug_dump_object( store, DEBUG_BIND ); debug_println( DEBUG_BIND ); - if (nilp( store) || consp(store)) { + if ( nilp( store ) || consp( store ) ) { result = make_cons( make_cons( key, value ), store ); - } else if (hashmapp( store)) { - result = hashmap_put( store, key, value); + } else if ( hashmapp( store ) ) { + result = hashmap_put( store, key, value ); } - debug_print( L"set returning ", DEBUG_BIND); - debug_print_object( result, DEBUG_BIND); - debug_println( DEBUG_BIND); + debug_print( L"set returning ", DEBUG_BIND ); + debug_print_object( result, DEBUG_BIND ); + debug_println( DEBUG_BIND ); return result; } @@ -195,4 +197,3 @@ intern( struct cons_pointer key, struct cons_pointer environment ) { return result; } - diff --git a/src/ops/lispops.c b/src/ops/lispops.c index 474784d..454fb9a 100644 --- a/src/ops/lispops.c +++ b/src/ops/lispops.c @@ -106,7 +106,7 @@ struct cons_pointer eval_forms( struct stack_frame *frame, list = c_cdr( list ); } - return c_reverse( result); + return c_reverse( result ); } /** @@ -121,19 +121,18 @@ struct cons_pointer eval_forms( struct stack_frame *frame, * * This is experimental. It almost certainly WILL change. */ -struct cons_pointer lisp_try(struct stack_frame *frame, - struct cons_pointer frame_pointer, - struct cons_pointer env) { - struct cons_pointer result = c_progn(frame, frame_pointer, frame->arg[0], env); +struct cons_pointer lisp_try( struct stack_frame *frame, + struct cons_pointer frame_pointer, + struct cons_pointer env ) { + struct cons_pointer result = + c_progn( frame, frame_pointer, frame->arg[0], env ); - if (exceptionp(result)) - { + if ( exceptionp( result ) ) { // TODO: need to put the exception into the environment! - result = c_progn(frame, frame_pointer, frame->arg[1], - make_cons( - make_cons(c_string_to_lisp_keyword(L"*exception*"), - result), - env)); + result = c_progn( frame, frame_pointer, frame->arg[1], + make_cons( make_cons + ( c_string_to_lisp_keyword + ( L"*exception*" ), result ), env ) ); } return result; @@ -282,8 +281,7 @@ eval_lambda( struct cons_space_object cell, struct stack_frame *frame, result = eval_form( frame, frame_pointer, sexpr, new_env ); - if (exceptionp(result)) - { + if ( exceptionp( result ) ) { break; } } @@ -306,8 +304,8 @@ eval_lambda( struct cons_space_object cell, struct stack_frame *frame, * @return the result of evaluating the function with its arguments. */ struct cons_pointer - c_apply( struct stack_frame *frame, struct cons_pointer frame_pointer, - struct cons_pointer env ) { +c_apply( struct stack_frame *frame, struct cons_pointer frame_pointer, + struct cons_pointer env ) { debug_print( L"Entering c_apply\n", DEBUG_EVAL ); struct cons_pointer result = NIL; @@ -322,122 +320,124 @@ struct cons_pointer switch ( fn_cell.tag.value ) { case EXCEPTIONTV: - /* just pass exceptions straight back */ - result = fn_pointer; - break; + /* just pass exceptions straight back */ + result = fn_pointer; + break; case FUNCTIONTV: - { - struct cons_pointer exep = NIL; - struct cons_pointer next_pointer = - make_stack_frame( frame_pointer, args, env ); - inc_ref( next_pointer ); - if ( exceptionp( next_pointer ) ) { - result = next_pointer; - } else { - struct stack_frame *next = - get_stack_frame( next_pointer ); + { + struct cons_pointer exep = NIL; + struct cons_pointer next_pointer = + make_stack_frame( frame_pointer, args, env ); + inc_ref( next_pointer ); + if ( exceptionp( next_pointer ) ) { + result = next_pointer; + } else { + struct stack_frame *next = + get_stack_frame( next_pointer ); - result = - ( *fn_cell.payload.function.executable ) ( next, - next_pointer, - env ); - dec_ref( next_pointer ); - } - } - break; - - case KEYTV: - result = c_assoc( fn_pointer, - eval_form(frame, - frame_pointer, - c_car( c_cdr( frame->arg[0])), - env)); - break; - - case LAMBDATV: - { - struct cons_pointer exep = NIL; - struct cons_pointer next_pointer = - make_stack_frame( frame_pointer, args, env ); - inc_ref( next_pointer ); - if ( exceptionp( next_pointer ) ) { - result = next_pointer; - } else { - struct stack_frame *next = - get_stack_frame( next_pointer ); - result = - eval_lambda( fn_cell, next, next_pointer, env ); - if ( !exceptionp( result ) ) { + result = + ( *fn_cell.payload.function.executable ) ( next, + next_pointer, + env ); dec_ref( next_pointer ); } } - } - break; + break; + + case KEYTV: + result = c_assoc( fn_pointer, + eval_form( frame, + frame_pointer, + c_car( c_cdr( frame->arg[0] ) ), + env ) ); + break; + + case LAMBDATV: + { + struct cons_pointer exep = NIL; + struct cons_pointer next_pointer = + make_stack_frame( frame_pointer, args, env ); + inc_ref( next_pointer ); + if ( exceptionp( next_pointer ) ) { + result = next_pointer; + } else { + struct stack_frame *next = + get_stack_frame( next_pointer ); + result = + eval_lambda( fn_cell, next, next_pointer, env ); + if ( !exceptionp( result ) ) { + dec_ref( next_pointer ); + } + } + } + break; case VECTORPOINTTV: - switch ( pointer_to_vso(fn_pointer)->header.tag.value) { - case HASHTV: - /* \todo: if arg[0] is a CONS, treat it as a path */ - result = c_assoc( eval_form(frame, - frame_pointer, - c_car( c_cdr( frame->arg[0])), - env), - fn_pointer); + switch ( pointer_to_vso( fn_pointer )->header.tag.value ) { + case HASHTV: + /* \todo: if arg[0] is a CONS, treat it as a path */ + result = c_assoc( eval_form( frame, + frame_pointer, + c_car( c_cdr + ( frame-> + arg[0] ) ), + env ), fn_pointer ); + break; + } break; - } - break; case NLAMBDATV: - { - struct cons_pointer next_pointer = - make_special_frame( frame_pointer, args, env ); - inc_ref( next_pointer ); - if ( exceptionp( next_pointer ) ) { - result = next_pointer; - } else { - struct stack_frame *next = - get_stack_frame( next_pointer ); - result = - eval_lambda( fn_cell, next, next_pointer, env ); - dec_ref( next_pointer ); + { + struct cons_pointer next_pointer = + make_special_frame( frame_pointer, args, env ); + inc_ref( next_pointer ); + if ( exceptionp( next_pointer ) ) { + result = next_pointer; + } else { + struct stack_frame *next = + get_stack_frame( next_pointer ); + result = + eval_lambda( fn_cell, next, next_pointer, env ); + dec_ref( next_pointer ); + } } - } - break; + break; case SPECIALTV: - { - struct cons_pointer next_pointer = - make_special_frame( frame_pointer, args, env ); - inc_ref( next_pointer ); - if ( exceptionp( next_pointer ) ) { - result = next_pointer; - } else { - result = - ( *fn_cell.payload.special. - executable ) ( get_stack_frame( next_pointer ), - next_pointer, env ); - debug_print( L"Special form returning: ", DEBUG_EVAL ); - debug_print_object( result, DEBUG_EVAL ); - debug_println( DEBUG_EVAL ); - dec_ref( next_pointer ); + { + struct cons_pointer next_pointer = + make_special_frame( frame_pointer, args, env ); + inc_ref( next_pointer ); + if ( exceptionp( next_pointer ) ) { + result = next_pointer; + } else { + result = + ( *fn_cell.payload. + special.executable ) ( get_stack_frame + ( next_pointer ), + next_pointer, env ); + debug_print( L"Special form returning: ", DEBUG_EVAL ); + debug_print_object( result, DEBUG_EVAL ); + debug_println( DEBUG_EVAL ); + dec_ref( next_pointer ); + } } - } - break; + break; default: - { - int bs = sizeof( wchar_t ) * 1024; - wchar_t *buffer = malloc( bs ); - memset( buffer, '\0', bs ); - swprintf( buffer, bs, - L"Unexpected cell with tag %d (%4.4s) in function position", - fn_cell.tag.value, &fn_cell.tag.bytes[0] ); - struct cons_pointer message = - c_string_to_lisp_string( buffer ); - free( buffer ); - result = throw_exception( message, frame_pointer ); - } + { + int bs = sizeof( wchar_t ) * 1024; + wchar_t *buffer = malloc( bs ); + memset( buffer, '\0', bs ); + swprintf( buffer, bs, + L"Unexpected cell with tag %d (%4.4s) in function position", + fn_cell.tag.value, &fn_cell.tag.bytes[0] ); + struct cons_pointer message = + c_string_to_lisp_string( buffer ); + free( buffer ); + result = throw_exception( message, frame_pointer ); + } } } @@ -479,7 +479,7 @@ lisp_eval( struct stack_frame *frame, struct cons_pointer frame_pointer, switch ( cell.tag.value ) { case CONSTV: - result = c_apply( frame, frame_pointer, env ); + result = c_apply( frame, frame_pointer, env ); break; case SYMBOLTV: @@ -781,9 +781,10 @@ lisp_cdr( struct stack_frame *frame, struct cons_pointer frame_pointer, * @param env my environment (ignored). * @return the length of `any`, if it is a sequence, or zero otherwise. */ -struct cons_pointer lisp_length( struct stack_frame *frame, struct cons_pointer frame_pointer, - struct cons_pointer env ) { - return make_integer( c_length( frame->arg[0]), NIL); +struct cons_pointer lisp_length( struct stack_frame *frame, + struct cons_pointer frame_pointer, + struct cons_pointer env ) { + return make_integer( c_length( frame->arg[0] ), NIL ); } /** @@ -802,24 +803,24 @@ lisp_assoc( struct stack_frame *frame, struct cons_pointer frame_pointer, return c_assoc( frame->arg[0], frame->arg[1] ); } -struct cons_pointer c_keys(struct cons_pointer store) { - struct cons_pointer result = NIL; +struct cons_pointer c_keys( struct cons_pointer store ) { + struct cons_pointer result = NIL; - if ( hashmapp( store ) ) { - result = hashmap_keys( store ); - } else if ( consp( store ) ) { - for ( struct cons_pointer c = store; !nilp( c ); c = c_cdr( c ) ) { - result = make_cons( c_car( c ), result ); + if ( hashmapp( store ) ) { + result = hashmap_keys( store ); + } else if ( consp( store ) ) { + for ( struct cons_pointer c = store; !nilp( c ); c = c_cdr( c ) ) { + result = make_cons( c_car( c ), result ); + } } - } - return result; + return result; } struct cons_pointer lisp_keys( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ) { - return c_keys( frame->arg[0]); + return c_keys( frame->arg[0] ); } /** @@ -962,26 +963,26 @@ struct cons_pointer lisp_reverse( struct stack_frame *frame, struct cons_pointer lisp_inspect( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ) { - debug_print( L"Entering lisp_inspect\n", DEBUG_IO ); - struct cons_pointer result = NIL; - struct cons_pointer out_stream = writep( frame->arg[1] ) - ? frame->arg[1] - : get_default_stream( false, env ); - URL_FILE *output; + debug_print( L"Entering lisp_inspect\n", DEBUG_IO ); + struct cons_pointer result = NIL; + struct cons_pointer out_stream = writep( frame->arg[1] ) + ? frame->arg[1] + : get_default_stream( false, env ); + URL_FILE *output; - if ( writep( out_stream ) ) { - debug_print( L"lisp_inspect: setting output stream\n", DEBUG_IO ); - debug_dump_object( out_stream, DEBUG_IO ); - output = pointer2cell( out_stream ).payload.stream.stream; - } else { - output = file_to_url_file( stderr ); - } + if ( writep( out_stream ) ) { + debug_print( L"lisp_inspect: setting output stream\n", DEBUG_IO ); + debug_dump_object( out_stream, DEBUG_IO ); + output = pointer2cell( out_stream ).payload.stream.stream; + } else { + output = file_to_url_file( stderr ); + } - dump_object( output, frame->arg[0] ); + dump_object( output, frame->arg[0] ); - debug_print( L"Leaving lisp_inspect", DEBUG_IO ); + debug_print( L"Leaving lisp_inspect", DEBUG_IO ); - return result; + return result; } /** @@ -1064,7 +1065,7 @@ c_progn( struct stack_frame *frame, struct cons_pointer frame_pointer, result = eval_form( frame, frame_pointer, c_car( expressions ), env ); dec_ref( r ); - expressions = exceptionp(result) ? NIL : c_cdr( expressions ); + expressions = exceptionp( result ) ? NIL : c_cdr( expressions ); } return result; @@ -1332,7 +1333,7 @@ struct cons_pointer lisp_source( struct stack_frame *frame, case SPECIALTV: result = c_assoc( source_key, cell.payload.special.meta ); break; - case LAMBDATV: + case LAMBDATV: result = make_cons( c_string_to_lisp_symbol( L"lambda" ), make_cons( cell.payload.lambda.args, cell.payload.lambda.body ) ); diff --git a/src/ops/lispops.h b/src/ops/lispops.h index 014df2e..c1cc337 100644 --- a/src/ops/lispops.h +++ b/src/ops/lispops.h @@ -127,8 +127,8 @@ struct cons_pointer lisp_cdr( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ); struct cons_pointer lisp_inspect( struct stack_frame *frame, - struct cons_pointer frame_pointer, - struct cons_pointer env ); + struct cons_pointer frame_pointer, + struct cons_pointer env ); struct cons_pointer lisp_eq( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ); diff --git a/src/time/psse_time.c b/src/time/psse_time.c index e37e522..1f24b0e 100644 --- a/src/time/psse_time.c +++ b/src/time/psse_time.c @@ -28,42 +28,44 @@ * PSSE Lisp epoch is 14 Bn years, or 441,806,400,000,000,000 seconds, before * the UNIX epoch; the value in microseconds will break the C reader. */ -unsigned __int128 epoch_offset = ((__int128)(seconds_per_year * 1000000000L) * - (__int128)(14L * 1000000000L)); +unsigned __int128 epoch_offset = + ( ( __int128 ) ( seconds_per_year * 1000000000L ) * + ( __int128 ) ( 14L * 1000000000L ) ); /** * Return the UNIX time value which represents this time, if it falls within * the period representable in UNIX time, or zero otherwise. */ -long int lisp_time_to_unix_time(struct cons_pointer t) { +long int lisp_time_to_unix_time( struct cons_pointer t ) { long int result = 0; - if (timep( t)) { - unsigned __int128 value = pointer2cell(t).payload.time.value; + if ( timep( t ) ) { + unsigned __int128 value = pointer2cell( t ).payload.time.value; - if (value > epoch_offset) { // \todo && value < UNIX time rollover - result = ((value - epoch_offset) / 1000000000); + if ( value > epoch_offset ) { // \todo && value < UNIX time rollover + result = ( ( value - epoch_offset ) / 1000000000 ); } } return result; } -unsigned __int128 unix_time_to_lisp_time( time_t t) { - unsigned __int128 result = epoch_offset + (t * 1000000000); +unsigned __int128 unix_time_to_lisp_time( time_t t ) { + unsigned __int128 result = epoch_offset + ( t * 1000000000 ); return result; } -struct cons_pointer make_time( struct cons_pointer integer_or_nil) { +struct cons_pointer make_time( struct cons_pointer integer_or_nil ) { struct cons_pointer pointer = allocate_cell( TIMETV ); struct cons_space_object *cell = &pointer2cell( pointer ); - if (integerp(integer_or_nil)) { - cell->payload.time.value = pointer2cell(integer_or_nil).payload.integer.value; + if ( integerp( integer_or_nil ) ) { + cell->payload.time.value = + pointer2cell( integer_or_nil ).payload.integer.value; // \todo: if integer is a bignum, deal with it. } else { - cell->payload.time.value = unix_time_to_lisp_time( time(NULL)); + cell->payload.time.value = unix_time_to_lisp_time( time( NULL ) ); } return pointer; @@ -82,25 +84,26 @@ struct cons_pointer make_time( struct cons_pointer integer_or_nil) { * is that number of microseconds after the notional big bang; else the current * time. */ -struct cons_pointer lisp_time( struct stack_frame *frame, struct cons_pointer frame_pointer, - struct cons_pointer env ) { - return make_time( frame->arg[0]); +struct cons_pointer lisp_time( struct stack_frame *frame, + struct cons_pointer frame_pointer, + struct cons_pointer env ) { + return make_time( frame->arg[0] ); } /** * This is temporary, for bootstrapping. */ -struct cons_pointer time_to_string( struct cons_pointer pointer) { +struct cons_pointer time_to_string( struct cons_pointer pointer ) { struct cons_pointer result = NIL; - long int t = lisp_time_to_unix_time(pointer); + long int t = lisp_time_to_unix_time( pointer ); - if ( t != 0) { - char * bytes = ctime(&t); - int l = strlen(bytes) + 1; - wchar_t buffer[ l]; + if ( t != 0 ) { + char *bytes = ctime( &t ); + int l = strlen( bytes ) + 1; + wchar_t buffer[l]; - mbstowcs( buffer, bytes, l); - result = c_string_to_lisp_string( buffer); + mbstowcs( buffer, bytes, l ); + result = c_string_to_lisp_string( buffer ); } return result; diff --git a/src/time/psse_time.h b/src/time/psse_time.h index af70966..f2afdd2 100644 --- a/src/time/psse_time.h +++ b/src/time/psse_time.h @@ -13,8 +13,9 @@ #define _GNU_SOURCE #include "consspaceobject.h" -struct cons_pointer lisp_time( struct stack_frame *frame, struct cons_pointer frame_pointer, - struct cons_pointer env ); -struct cons_pointer time_to_string( struct cons_pointer pointer); +struct cons_pointer lisp_time( struct stack_frame *frame, + struct cons_pointer frame_pointer, + struct cons_pointer env ); +struct cons_pointer time_to_string( struct cons_pointer pointer ); #endif From b6ae110f66ac1c85f1f9b00e45db1610c198608d Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Wed, 18 Aug 2021 11:00:47 +0100 Subject: [PATCH 13/28] Hybrid assoc lists --- docs/Hybrid-assoc-lists.md | 40 ++++++++++++++++++ src/ops/equal.c | 1 + src/ops/intern.c | 85 +++++++++++++++++++++----------------- 3 files changed, 89 insertions(+), 37 deletions(-) create mode 100644 docs/Hybrid-assoc-lists.md diff --git a/docs/Hybrid-assoc-lists.md b/docs/Hybrid-assoc-lists.md new file mode 100644 index 0000000..5bb6ca8 --- /dev/null +++ b/docs/Hybrid-assoc-lists.md @@ -0,0 +1,40 @@ +# Hybrid assoc lists + +In it's current very prototype stage, PSSE has to forms of name/value store. One is the assoc list, the other is the hashmap. + +An assoc (association) list is a list of the form: + + ((name1 . value1)(name2 . value2)(name3 . value3)...) + +Hashmaps have many very clear advantages, but assoc lists have one which is very important in the evaluation environment, and that is precisely its sequentiality. Thus, if the same name is bound twice on an assoc list, the value nearest the head is the one which will be recovered: + + (assoc :bar '((:foo . 1) (:bar . "Hello there!")(:ban . 3)(:bar . 2))) + => "Hello there!" + +Why does this matter? Well, for precisely the same reason it matters when a UNIX system searches for an executable. + +Suppose Clare is a user who trusts both Alice and Bob, but she trusts Alice more than Bob. Suppose both Alice and Bob have written implementations of a function called `froboz`. Suppose Clare invokes + + (froboz 3) + +Which implementation of `froboz` should be evaluated? An assoc list makes that simple. If Clare binds Alice's implementation into her environment later than Bob's, Alice's will be the one found. + +But an assoc list is also fearsomely inefficient, especially if we are in a system with many thousands of names, each of which may be bound multiple times in typical runtime environment. + +How to resolve this? How to get some of the benefits of sequential access of assoc lists, with some of the efficiency benefits of hashmaps? What I'm going to propose is a **hybrid assoc list**, that is to say, a list whose members are either + +1. (key . value) pairs, or else +2. hashmaps. + +So suppose we have a list, `l`, thus: + + ((:foo . 1) (:bar . 2) {:foo "not this" :ban 3} (:ban . "not this either") (:froboz . 4)) + +Then: + + (assoc :foo l) => 1 + (assoc :bar l) => 2 + (assoc :ban l) => 3 + (assoc :froboz l) => 4 + +This will make the implementation of namespaces and search paths vastly easier. \ No newline at end of file diff --git a/src/ops/equal.c b/src/ops/equal.c index a02acc8..36f73ed 100644 --- a/src/ops/equal.c +++ b/src/ops/equal.c @@ -82,6 +82,7 @@ bool equal( struct cons_pointer a, struct cons_pointer b ) { * structures can be of indefinite extent. It *must* be done by * iteration (and even that is problematic) */ result = + cell_a->payload.string.hash == cell_b->payload.string.hash && cell_a->payload.string.character == cell_b->payload.string.character && ( equal( cell_a->payload.string.cdr, diff --git a/src/ops/intern.c b/src/ops/intern.c index d7b81c6..e541bdf 100644 --- a/src/ops/intern.c +++ b/src/ops/intern.c @@ -90,56 +90,67 @@ internedp( struct cons_pointer key, struct cons_pointer store ) { */ struct cons_pointer c_assoc( struct cons_pointer key, struct cons_pointer store ) { - struct cons_pointer result = NIL; + struct cons_pointer result = NIL; - debug_print( L"c_assoc; key is `", DEBUG_BIND ); - debug_print_object( key, DEBUG_BIND ); - debug_print( L"`\n", DEBUG_BIND ); + debug_print( L"c_assoc; key is `", DEBUG_BIND ); + debug_print_object( key, DEBUG_BIND ); + debug_print( L"`\n", DEBUG_BIND ); - if ( consp( store ) ) { - for ( struct cons_pointer next = store; - consp( next ); next = pointer2cell( next ).payload.cons.cdr ) { - struct cons_space_object entry = - pointer2cell( pointer2cell( next ).payload.cons.car ); + if ( consp( store ) ) { + for ( struct cons_pointer next = store; + nilp( result ) && ( consp( next ) || hashmapp( next ) ); + next = pointer2cell( next ).payload.cons.cdr ) { + if ( consp( next ) ) { + struct cons_pointer entry_ptr = c_car( next ); + struct cons_space_object entry = pointer2cell( entry_ptr ); + switch ( entry.tag.value ) { + case CONSTV: if ( equal( key, entry.payload.cons.car ) ) { - result = entry.payload.cons.cdr; - break; + result = entry.payload.cons.cdr; } + break; + case VECTORPOINTTV: + result = hashmap_get( entry_ptr, key ); + break; + default: + throw_exception( + c_string_to_lisp_string( L"Store entry is of unknown type" ), + NIL ); } - } else if ( hashmapp( store ) ) { - result = hashmap_get( store, key ); - } else { - result = - throw_exception( c_string_to_lisp_string - ( L"Store is of unknown type" ), NIL ); + } } + } else if ( hashmapp( store ) ) { + result = hashmap_get( store, key ); + } else if (!nilp(store)) { + result = throw_exception( + c_string_to_lisp_string( L"Store is of unknown type" ), NIL ); + } - debug_print( L"c_assoc returning ", DEBUG_BIND ); - debug_print_object( result, DEBUG_BIND ); - debug_println( DEBUG_BIND ); + debug_print( L"c_assoc returning ", DEBUG_BIND ); + debug_print_object( result, DEBUG_BIND ); + debug_println( DEBUG_BIND ); - return result; + return result; } -/** - * Return a new key/value store containing all the key/value pairs in this store - * with this key/value pair added to the front. - */ -struct cons_pointer -set( struct cons_pointer key, struct cons_pointer value, - struct cons_pointer store ) { - struct cons_pointer result = NIL; + /** + * Return a new key/value store containing all the key/value pairs in this + * store with this key/value pair added to the front. + */ + struct cons_pointer set( struct cons_pointer key, struct cons_pointer value, + struct cons_pointer store ) { + struct cons_pointer result = NIL; - debug_print( L"set: binding `", DEBUG_BIND ); - debug_print_object( key, DEBUG_BIND ); - debug_print( L"` to `", DEBUG_BIND ); - debug_print_object( value, DEBUG_BIND ); - debug_print( L"` in store ", DEBUG_BIND ); - debug_dump_object( store, DEBUG_BIND ); - debug_println( DEBUG_BIND ); + debug_print( L"set: binding `", DEBUG_BIND ); + debug_print_object( key, DEBUG_BIND ); + debug_print( L"` to `", DEBUG_BIND ); + debug_print_object( value, DEBUG_BIND ); + debug_print( L"` in store ", DEBUG_BIND ); + debug_dump_object( store, DEBUG_BIND ); + debug_println( DEBUG_BIND ); - if ( nilp( store ) || consp( store ) ) { + if ( nilp( store ) || consp( store ) ) { result = make_cons( make_cons( key, value ), store ); } else if ( hashmapp( store ) ) { result = hashmap_put( store, key, value ); From 5c6ac7f75dcb07478e6ade237b85be92221fe52b Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Wed, 18 Aug 2021 13:40:35 +0100 Subject: [PATCH 14/28] Making progress on paths! --- docs/How-do-we-notate-paths.md | 89 +++++++++++++++++++++++++++++++++ src/memory/hashmap.c | 13 +++-- src/ops/equal.c | 16 +++--- src/ops/intern.c | 91 +++++++++++++++++----------------- src/ops/lispops.c | 6 +-- 5 files changed, 153 insertions(+), 62 deletions(-) create mode 100644 docs/How-do-we-notate-paths.md diff --git a/docs/How-do-we-notate-paths.md b/docs/How-do-we-notate-paths.md new file mode 100644 index 0000000..7cdbcb0 --- /dev/null +++ b/docs/How-do-we-notate-paths.md @@ -0,0 +1,89 @@ +# How do we notate paths? + +In order to make the namespaces thing work, we need a convenient way to notate paths from the current namespace to a target, or from the root to a target. This is similar to relative and absolute paths in UNIX, except that in PSSE there is no concept of a single or privileged ancestor namespace to the current namespace, so you have no equivalent of `../`. + +In this discussion, a **namespace** is just a named, mutable hashmap (but not necessarily mutable by all users; indeed namespaces will almost always be mutable only by selected users. I cannot presently see a justified use for a publicly writable namespace). '**Named**', of a hashmap, merely means there is some path from the privileged root namespace which is the value of `oblist` which leads to that hashmap. A **path** is in principle just a sequence of keys, such that the value of each successive key is bound to a namespace in the namespace bound by its predecessor. The evaluable implementation of paths will be discussed later. + +I think also that there must be a privileged **session** namespace, containing information about the current session, which the user can read but not write. + +## Security considerations + +What's important is that a user cannot rebind privileged names in their own environment. Thus to ensure privileged names, such names must be paths either from the `oblist`or from the current session. So we need magic, privileged notations for these things built into the reader, which cannot be overridden. + +This kind of takes away from my general feeling that users should be able to override *anything*. but hey, that's engineering for you. + +Users should be able to override reader macros generally; a programmable reader is in the medium term something which should be implemented. But the privileged syntax for paths should not be overridable. + +## Current state of the reader + +At present, you can rebind the value of the symbol `oblist` in the runtime environment. In principle, you should be able to rebind any symbol. Paths and symbols are not the same. + +At present, the colon character is a separator character. So if you type + +> (list :foo:bar:ban) + +the reader will return + +> (list :foo :bar :ban) + +That's significant, and helpful. + +## Constructing path notation + +The Clojure threading macro, `->`, is a useful example of how we can implement this. Essentially it takes a expression as its first argument, passes the value of that expression to the function which is its second argument, the value of that as argument to the function which is its next, and so on. Given that, in Clojure, an expression which has a keyword in the function position and a hashmap in the argument position will return the value of that keyword in that hashmap, this means that, given the hashmap + +> (def x {:foo {:bar {:ban "Howzat!!"}}}) + +the expression + +> (-> x :foo :bar :ban) + +will return + +> "Howzat!!" + +So, in general, if we implement the 'keyword in the function position' `eval` hack and the threading macro, then something like + +> (-> oblist :users :simon :functions 'foo) + +should return the value of the symbol `foo` in the `:functions` of the user called `:simon`. + +That's stage one of our goal. + +Stage two of our goal is that a stream of non-separator characters separated by colons should be interpreted as a list of keywords. Thus typing + +> :foo:bar:ban + +should result in not just `:foo`being read, but the list `(:foo :bar :ban)`(? not sure about this) + +Stage 3 is to allow a symbol to be appended to a sequence of keywords written by using `/`as a separator, so + +> :foo:bar/ban + +would be read as `(:foo :bar 'ban)` + +Finally, we need privileged notation for root (oblist) and for session. There are very few non-alpha-numeric characters which are available on a standard keyboard and which are not already used as significant lexical characters in Lisp readers. PSSE is not limited, of course, to the characters which are part of the ASCII character set, but it is helpful to use symbols which are reasonably convenient to type, possibly with special keyboard bindings. + +So I'm going to propose that the reader should interpret + +> /:users:simon:functions/assoc + +as + +> (-> oblist :users :simon :functions 'assoc) + +where `oblist` is the actual privileged global object list, not just the current binding of `oblist` in the environment. Thus, this expression would return my personal version of the function `assoc`, whatever the symbol `assoc` was bound to in the runtime environment. + +The use of the leading slash here follows UNIX convention. + +I'm going to suggest that the session is referenced by the character §, otherwise known as the 'silcrow'. This is not available on most keyboard mappings, so a custom mapping might be needed, or we might have to fall back on `$`. + +Thus the reader should interpret + +> §:user + +as + +> (-> session :user) + +where `session`is again a system privileged value, not the binding of `session` in the current environment. \ No newline at end of file diff --git a/src/memory/hashmap.c b/src/memory/hashmap.c index 2e68cda..efc0e88 100644 --- a/src/memory/hashmap.c +++ b/src/memory/hashmap.c @@ -110,10 +110,10 @@ struct cons_pointer lisp_get_hash( struct stack_frame *frame, struct cons_pointer make_hashmap( uint32_t n_buckets, struct cons_pointer hash_fn, struct cons_pointer write_acl ) { - struct cons_pointer result = - make_vso( HASHTV, - ( sizeof( struct cons_pointer ) * ( n_buckets + 1 ) ) + - ( sizeof( uint32_t ) * 2 ) ); + struct cons_pointer result = make_vso( HASHTV, + ( sizeof( struct cons_pointer ) * + ( n_buckets + 1 ) ) + + ( sizeof( uint32_t ) * 2 ) ); struct hashmap_payload *payload = ( struct hashmap_payload * ) &pointer_to_vso( result )->payload; @@ -175,9 +175,8 @@ struct cons_pointer lisp_make_hashmap( struct stack_frame *frame, struct cons_pointer val = c_cdr( pair ); uint32_t bucket_no = - get_hash( key ) % - ( ( struct hashmap_payload * ) &( map->payload ) )-> - n_buckets; + get_hash( key ) % ( ( struct hashmap_payload * ) + &( map->payload ) )->n_buckets; map->payload.hashmap.buckets[bucket_no] = inc_ref( make_cons( make_cons( key, val ), diff --git a/src/ops/equal.c b/src/ops/equal.c index 36f73ed..39d80af 100644 --- a/src/ops/equal.c +++ b/src/ops/equal.c @@ -82,13 +82,15 @@ bool equal( struct cons_pointer a, struct cons_pointer b ) { * structures can be of indefinite extent. It *must* be done by * iteration (and even that is problematic) */ result = - cell_a->payload.string.hash == cell_b->payload.string.hash && - cell_a->payload.string.character == - cell_b->payload.string.character && - ( equal( cell_a->payload.string.cdr, - cell_b->payload.string.cdr ) || - ( end_of_string( cell_a->payload.string.cdr ) - && end_of_string( cell_b->payload.string.cdr ) ) ); + cell_a->payload.string.hash == cell_b->payload.string.hash + && cell_a->payload.string.character == + cell_b->payload.string.character + && + ( equal + ( cell_a->payload.string.cdr, + cell_b->payload.string.cdr ) + || ( end_of_string( cell_a->payload.string.cdr ) + && end_of_string( cell_b->payload.string.cdr ) ) ); break; case INTEGERTV: result = diff --git a/src/ops/intern.c b/src/ops/intern.c index e541bdf..d7a6c0d 100644 --- a/src/ops/intern.c +++ b/src/ops/intern.c @@ -90,67 +90,68 @@ internedp( struct cons_pointer key, struct cons_pointer store ) { */ struct cons_pointer c_assoc( struct cons_pointer key, struct cons_pointer store ) { - struct cons_pointer result = NIL; + struct cons_pointer result = NIL; - debug_print( L"c_assoc; key is `", DEBUG_BIND ); - debug_print_object( key, DEBUG_BIND ); - debug_print( L"`\n", DEBUG_BIND ); + debug_print( L"c_assoc; key is `", DEBUG_BIND ); + debug_print_object( key, DEBUG_BIND ); + debug_print( L"`\n", DEBUG_BIND ); - if ( consp( store ) ) { - for ( struct cons_pointer next = store; - nilp( result ) && ( consp( next ) || hashmapp( next ) ); - next = pointer2cell( next ).payload.cons.cdr ) { - if ( consp( next ) ) { - struct cons_pointer entry_ptr = c_car( next ); - struct cons_space_object entry = pointer2cell( entry_ptr ); + if ( consp( store ) ) { + for ( struct cons_pointer next = store; + nilp( result ) && ( consp( next ) || hashmapp( next ) ); + next = pointer2cell( next ).payload.cons.cdr ) { + if ( consp( next ) ) { + struct cons_pointer entry_ptr = c_car( next ); + struct cons_space_object entry = pointer2cell( entry_ptr ); - switch ( entry.tag.value ) { - case CONSTV: - if ( equal( key, entry.payload.cons.car ) ) { - result = entry.payload.cons.cdr; + switch ( entry.tag.value ) { + case CONSTV: + if ( equal( key, entry.payload.cons.car ) ) { + result = entry.payload.cons.cdr; + } + break; + case VECTORPOINTTV: + result = hashmap_get( entry_ptr, key ); + break; + default: + throw_exception( c_string_to_lisp_string + ( L"Store entry is of unknown type" ), + NIL ); + } } - break; - case VECTORPOINTTV: - result = hashmap_get( entry_ptr, key ); - break; - default: - throw_exception( - c_string_to_lisp_string( L"Store entry is of unknown type" ), - NIL ); } - } + } else if ( hashmapp( store ) ) { + result = hashmap_get( store, key ); + } else if ( !nilp( store ) ) { + result = + throw_exception( c_string_to_lisp_string + ( L"Store is of unknown type" ), NIL ); } - } else if ( hashmapp( store ) ) { - result = hashmap_get( store, key ); - } else if (!nilp(store)) { - result = throw_exception( - c_string_to_lisp_string( L"Store is of unknown type" ), NIL ); - } - debug_print( L"c_assoc returning ", DEBUG_BIND ); - debug_print_object( result, DEBUG_BIND ); - debug_println( DEBUG_BIND ); + debug_print( L"c_assoc returning ", DEBUG_BIND ); + debug_print_object( result, DEBUG_BIND ); + debug_println( DEBUG_BIND ); - return result; + return result; } /** * Return a new key/value store containing all the key/value pairs in this * store with this key/value pair added to the front. */ - struct cons_pointer set( struct cons_pointer key, struct cons_pointer value, - struct cons_pointer store ) { - struct cons_pointer result = NIL; +struct cons_pointer set( struct cons_pointer key, struct cons_pointer value, + struct cons_pointer store ) { + struct cons_pointer result = NIL; - debug_print( L"set: binding `", DEBUG_BIND ); - debug_print_object( key, DEBUG_BIND ); - debug_print( L"` to `", DEBUG_BIND ); - debug_print_object( value, DEBUG_BIND ); - debug_print( L"` in store ", DEBUG_BIND ); - debug_dump_object( store, DEBUG_BIND ); - debug_println( DEBUG_BIND ); + debug_print( L"set: binding `", DEBUG_BIND ); + debug_print_object( key, DEBUG_BIND ); + debug_print( L"` to `", DEBUG_BIND ); + debug_print_object( value, DEBUG_BIND ); + debug_print( L"` in store ", DEBUG_BIND ); + debug_dump_object( store, DEBUG_BIND ); + debug_println( DEBUG_BIND ); - if ( nilp( store ) || consp( store ) ) { + if ( nilp( store ) || consp( store ) ) { result = make_cons( make_cons( key, value ), store ); } else if ( hashmapp( store ) ) { result = hashmap_put( store, key, value ); diff --git a/src/ops/lispops.c b/src/ops/lispops.c index 454fb9a..b173090 100644 --- a/src/ops/lispops.c +++ b/src/ops/lispops.c @@ -380,9 +380,9 @@ c_apply( struct stack_frame *frame, struct cons_pointer frame_pointer, result = c_assoc( eval_form( frame, frame_pointer, c_car( c_cdr - ( frame-> - arg[0] ) ), - env ), fn_pointer ); + ( frame->arg + [0] ) ), env ), + fn_pointer ); break; } break; From c63c262b740024dccfec261185fa520876d5354f Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Wed, 18 Aug 2021 18:48:05 +0100 Subject: [PATCH 15/28] Compact path notation now expands correctly --- src/init.c | 5 ++ src/io/read.c | 97 ++++++++++++++++++++++++++++++++++++- src/memory/hashmap.c | 2 +- src/ops/intern.c | 9 ++-- src/repl.c | 8 ++- unit-tests/map.sh | 1 + unit-tests/path-notation.sh | 31 ++++++++++++ 7 files changed, 145 insertions(+), 8 deletions(-) create mode 100755 unit-tests/path-notation.sh diff --git a/src/init.c b/src/init.c index ca48b9d..dbd7acf 100644 --- a/src/init.c +++ b/src/init.c @@ -163,6 +163,9 @@ int main( int argc, char *argv[] ) { debug_print( L"Initialised cons pages, about to bind\n", DEBUG_BOOTSTRAP ); +// TODO: oblist-as-hashmap (which is what we ultimately need) is failing hooribly +// oblist = inc_ref( make_hashmap( 32, NIL, TRUE ) ); + /* * privileged variables (keywords) */ @@ -271,7 +274,9 @@ int main( int argc, char *argv[] ) { bind_special( L"set!", &lisp_set_shriek ); debug_print( L"Initialised oblist\n", DEBUG_BOOTSTRAP ); debug_dump_object( oblist, DEBUG_BOOTSTRAP ); + repl( show_prompt ); + debug_print( L"Freeing oblist\n", DEBUG_BOOTSTRAP ); dec_ref( oblist ); debug_dump_object( oblist, DEBUG_BOOTSTRAP ); diff --git a/src/io/read.c b/src/io/read.c index 9c87932..4425b77 100644 --- a/src/io/read.c +++ b/src/io/read.c @@ -60,6 +60,77 @@ struct cons_pointer c_quote( struct cons_pointer arg ) { make_cons( arg, NIL ) ); } +/** + * Read a path macro from the stream. A path macro is expected to be + * 1. optionally a leading character such as '/' or '$', followed by + * 2. one or more keywords with leading colons (':') but no intervening spaces; or + * 3. one or more symbols separated by slashes; or + * 4. keywords (with leading colons) interspersed with symbols (prefixed by slashes). + */ +struct cons_pointer read_path( URL_FILE * input, wint_t initial, + struct cons_pointer q ) { + bool done = false; + struct cons_pointer prefix = NIL; + + switch ( initial ) { + case '/': + prefix = c_string_to_lisp_symbol( L"oblist" ); + break; + case '$': + case L'§': + prefix = c_string_to_lisp_symbol( L"session" ); + break; + } + + while ( !done ) { + wint_t c = url_fgetwc( input ); + if ( iswblank( c ) || iswcntrl( c ) ) { + done = true; + } else if ( url_feof( input ) ) { + done = true; + } else { + switch ( c ) { + case ':': + q = make_cons( read_symbol_or_key + ( input, KEYTV, url_fgetwc( input ) ), q ); + break; + case '/': + q = make_cons( make_cons + ( c_string_to_lisp_symbol( L"quote" ), + make_cons( read_symbol_or_key + ( input, SYMBOLTV, + url_fgetwc( input ) ), + NIL ) ), q ); + break; + default: + if ( iswalpha( c ) ) { + q = make_cons( read_symbol_or_key + ( input, SYMBOLTV, c ), q ); + } else { + // TODO: it's really an error. Exception? + url_ungetwc( c, input ); + done = true; + } + } + } + } + + // right, we now have the path we want (reversed) in q. + struct cons_pointer r = NIL; + + for ( struct cons_pointer p = q; !nilp( p ); p = c_cdr( p ) ) { + r = make_cons( c_car( p ), r ); + } + + dec_ref( q ); + + if ( !nilp( prefix ) ) { + r = make_cons( prefix, r ); + } + + return make_cons( c_string_to_lisp_symbol( L"->" ), r ); +} + /** * Read the next object on this input stream and return a cons_pointer to it, * treating this initial character as the first character of the object @@ -149,6 +220,27 @@ struct cons_pointer read_continuation( struct stack_frame *frame, result = read_symbol_or_key( input, KEYTV, url_fgetwc( input ) ); break; + case '/': + { + /* slash followed by whitespace is legit provided it's not + * preceded by anything - it's the division operator. Otherwise, + * it's terminal, probably part of a path, and needs pushed back. + */ + wint_t cn = url_fgetwc( input ); + if ( nilp( result ) + && ( iswblank( cn ) || iswcntrl( cn ) ) ) { + url_ungetwc( cn, input ); + result = make_symbol_or_key( c, NIL, SYMBOLTV ); + } else { + url_ungetwc( cn, input ); + result = read_path( input, c, NIL ); + } + } + break; + case '$': + case L'§': + result = read_path( input, c, NIL ); + break; default: if ( iswdigit( c ) ) { result = @@ -398,9 +490,10 @@ struct cons_pointer read_symbol_or_key( URL_FILE * input, uint32_t tag, /* unwise to allow embedded quotation marks in symbols */ case ')': case ':': + case '/': /* - * symbols and keywords may not include right-parenthesis - * or colons. + * symbols and keywords may not include right-parenthesis, + * slashes or colons. */ result = NIL; /* diff --git a/src/memory/hashmap.c b/src/memory/hashmap.c index efc0e88..cee9267 100644 --- a/src/memory/hashmap.c +++ b/src/memory/hashmap.c @@ -112,7 +112,7 @@ struct cons_pointer make_hashmap( uint32_t n_buckets, struct cons_pointer write_acl ) { struct cons_pointer result = make_vso( HASHTV, ( sizeof( struct cons_pointer ) * - ( n_buckets + 1 ) ) + + ( n_buckets + 2 ) ) + ( sizeof( uint32_t ) * 2 ) ); struct hashmap_payload *payload = diff --git a/src/ops/intern.c b/src/ops/intern.c index d7a6c0d..05d5822 100644 --- a/src/ops/intern.c +++ b/src/ops/intern.c @@ -25,7 +25,7 @@ #include "equal.h" #include "hashmap.h" #include "lispops.h" -#include "print.h" +// #include "print.h" /** * The global object list/or, to put it differently, the root namespace. @@ -181,8 +181,11 @@ deep_bind( struct cons_pointer key, struct cons_pointer value ) { debug_println( DEBUG_BIND ); oblist = set( key, value, oblist ); - inc_ref( oblist ); - dec_ref( old ); + + if ( consp( oblist ) ) { + inc_ref( oblist ); + dec_ref( old ); + } debug_print( L"deep_bind returning ", DEBUG_BIND ); debug_print_object( oblist, DEBUG_BIND ); diff --git a/src/repl.c b/src/repl.c index 0ea104d..39bbde6 100644 --- a/src/repl.c +++ b/src/repl.c @@ -24,12 +24,16 @@ void repl( ) { debug_print( L"Entered repl\n", DEBUG_REPL ); - struct cons_pointer frame_pointer = make_stack_frame( NIL, NIL, oblist ); + struct cons_pointer env = + consp( oblist ) ? oblist : make_cons( oblist, NIL ); + + /* bottom of stack */ + struct cons_pointer frame_pointer = make_stack_frame( NIL, NIL, env ); if ( !nilp( frame_pointer ) ) { inc_ref( frame_pointer ); - lisp_repl( get_stack_frame( frame_pointer ), frame_pointer, oblist ); + lisp_repl( get_stack_frame( frame_pointer ), frame_pointer, env ); dec_ref( frame_pointer ); } diff --git a/unit-tests/map.sh b/unit-tests/map.sh index c5fb834..65dc182 100755 --- a/unit-tests/map.sh +++ b/unit-tests/map.sh @@ -5,6 +5,7 @@ expected='{}' actual=`echo "$expected" | target/psse | tail -1` +echo -n "Empty map using compact map notation: " if [ "${expected}" = "${actual}" ] then echo "OK" diff --git a/unit-tests/path-notation.sh b/unit-tests/path-notation.sh new file mode 100755 index 0000000..a6cb669 --- /dev/null +++ b/unit-tests/path-notation.sh @@ -0,0 +1,31 @@ +#!/bin/bash + +##################################################################### +# Create a path from root using compact path notation +expected='(-> oblist :users :simon :functions (quote assoc))' +actual=`echo "'/:users:simon:functions/assoc" | target/psse | tail -1` + +echo -n "Path from root (oblist) using compact notation: " +if [ "${expected}" = "${actual}" ] +then + echo "OK" +else + echo "Fail: expected '${expected}', got '${actual}'" + exit 1 +fi + +##################################################################### +# Create a path from the current session using compact path notation +expected='(-> session :input-stream)' +actual=`echo "'$:input-stream" | target/psse | tail -1` + +echo -n "Path from current session using compact notation: " +if [ "${expected}" = "${actual}" ] +then + echo "OK" +else + echo "Fail: expected '${expected}', got '${actual}'" + exit 1 +fi + + From 6771d6494c5b95d1adc7029aa8920e763d0a71b6 Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Mon, 23 Aug 2021 12:35:05 +0100 Subject: [PATCH 16/28] Append works; mapcar doesn't; loop isn't even written. --- src/init.c | 2 + src/io/io.c | 4 +- src/memory/consspaceobject.h | 13 ++-- src/memory/dump.c | 8 +-- src/memory/hashmap.c | 4 +- src/ops/lispops.c | 121 +++++++++++++++++++++++++++++------ src/ops/lispops.h | 9 +++ src/ops/loop.c | 50 +++++++++++++++ src/ops/loop.h | 10 +++ unit-tests/append.sh | 24 +++++++ 10 files changed, 213 insertions(+), 32 deletions(-) create mode 100644 src/ops/loop.c create mode 100644 src/ops/loop.h create mode 100755 unit-tests/append.sh diff --git a/src/init.c b/src/init.c index dbd7acf..5e8a55d 100644 --- a/src/init.c +++ b/src/init.c @@ -220,6 +220,7 @@ int main( int argc, char *argv[] ) { */ bind_function( L"absolute", &lisp_absolute ); bind_function( L"add", &lisp_add ); + bind_function( L"append", &lisp_append ); bind_function( L"apply", &lisp_apply ); bind_function( L"assoc", &lisp_assoc ); bind_function( L"car", &lisp_car ); @@ -235,6 +236,7 @@ int main( int argc, char *argv[] ) { bind_function( L"hashmap", lisp_make_hashmap ); bind_function( L"inspect", &lisp_inspect ); bind_function( L"keys", &lisp_keys ); + bind_function( L"mapcar", &lisp_mapcar ); bind_function( L"meta", &lisp_metadata ); bind_function( L"metadata", &lisp_metadata ); bind_function( L"multiply", &lisp_multiply ); diff --git a/src/io/io.c b/src/io/io.c index f621539..72830a4 100644 --- a/src/io/io.c +++ b/src/io/io.c @@ -503,8 +503,8 @@ lisp_read_char( struct stack_frame *frame, struct cons_pointer frame_pointer, if ( readp( frame->arg[0] ) ) { result = make_string( url_fgetwc - ( pointer2cell( frame->arg[0] ).payload.stream. - stream ), NIL ); + ( pointer2cell( frame->arg[0] ).payload. + stream.stream ), NIL ); } return result; diff --git a/src/memory/consspaceobject.h b/src/memory/consspaceobject.h index 2817e69..7c3a390 100644 --- a/src/memory/consspaceobject.h +++ b/src/memory/consspaceobject.h @@ -114,12 +114,12 @@ * A loop exit is a special kind of exception which has exactly the same * payload as an exception. */ -#define LOOPXTAG "LOOX" +#define LOOPTAG "LOOP" /** * The string `LOOX`, considered as an `unsigned int`. */ -#define LOOPXTV 1481592652 +#define LOOPTV 1347374924 /** * The special cons cell at address {0,0} whose car and cdr both point to @@ -304,9 +304,9 @@ #define lambdap(conspoint) (check_tag(conspoint,LAMBDATV)) /** - * true if `conspoint` points to a loop exit exception, else false. + * true if `conspoint` points to a loop recursion, else false. */ -#define loopexitp(conspoint) (check_tag(conspoint,LOOPXTV)) +#define loopp(conspoint) (check_tag(conspoint,LOOPTV)) /** * true if `conspoint` points to a special form cell, else false @@ -615,7 +615,7 @@ struct cons_space_object { */ struct cons_payload cons; /** - * if tag == EXCEPTIONTAG || tag == LOOPXTAG + * if tag == EXCEPTIONTAG || tag == LOOPTAG */ struct exception_payload exception; /** @@ -713,6 +713,9 @@ struct cons_pointer make_special( struct cons_pointer src, struct cons_pointer, struct cons_pointer ) ); +struct cons_pointer make_string_like_thing( wint_t c, struct cons_pointer tail, + uint32_t tag ); + struct cons_pointer make_string( wint_t c, struct cons_pointer tail ); struct cons_pointer make_symbol_or_key( wint_t c, struct cons_pointer tail, diff --git a/src/memory/dump.c b/src/memory/dump.c index 086f8c8..81182a8 100644 --- a/src/memory/dump.c +++ b/src/memory/dump.c @@ -114,10 +114,10 @@ void dump_object( URL_FILE * output, struct cons_pointer pointer ) { case RATIOTV: url_fwprintf( output, L"\t\tRational cell: value %ld/%ld, count %u\n", - pointer2cell( cell.payload.ratio.dividend ).payload. - integer.value, - pointer2cell( cell.payload.ratio.divisor ).payload. - integer.value, cell.count ); + pointer2cell( cell.payload.ratio.dividend ). + payload.integer.value, + pointer2cell( cell.payload.ratio.divisor ). + payload.integer.value, cell.count ); break; case READTV: url_fputws( L"\t\tInput stream; metadata: ", output ); diff --git a/src/memory/hashmap.c b/src/memory/hashmap.c index cee9267..d6909ba 100644 --- a/src/memory/hashmap.c +++ b/src/memory/hashmap.c @@ -180,8 +180,8 @@ struct cons_pointer lisp_make_hashmap( struct stack_frame *frame, map->payload.hashmap.buckets[bucket_no] = inc_ref( make_cons( make_cons( key, val ), - map->payload.hashmap. - buckets[bucket_no] ) ); + map->payload. + hashmap.buckets[bucket_no] ) ); } } } diff --git a/src/ops/lispops.c b/src/ops/lispops.c index b173090..2356abe 100644 --- a/src/ops/lispops.c +++ b/src/ops/lispops.c @@ -413,10 +413,9 @@ c_apply( struct stack_frame *frame, struct cons_pointer frame_pointer, result = next_pointer; } else { result = - ( *fn_cell.payload. - special.executable ) ( get_stack_frame - ( next_pointer ), - next_pointer, env ); + ( *fn_cell.payload.special. + executable ) ( get_stack_frame( next_pointer ), + next_pointer, env ); debug_print( L"Special form returning: ", DEBUG_EVAL ); debug_print_object( result, DEBUG_EVAL ); debug_println( DEBUG_EVAL ); @@ -904,26 +903,30 @@ lisp_read( struct stack_frame *frame, struct cons_pointer frame_pointer, /** - * reverse a sequence. + * reverse a sequence (if it is a sequence); else return it unchanged. */ struct cons_pointer c_reverse( struct cons_pointer arg ) { struct cons_pointer result = NIL; - for ( struct cons_pointer p = arg; sequencep( p ); p = c_cdr( p ) ) { - struct cons_space_object o = pointer2cell( p ); - switch ( o.tag.value ) { - case CONSTV: - result = make_cons( o.payload.cons.car, result ); - break; - case STRINGTV: - result = make_string( o.payload.string.character, result ); - break; - case SYMBOLTV: - result = - make_symbol_or_key( o.payload.string.character, result, - SYMBOLTV ); - break; + if ( sequencep( arg ) ) { + for ( struct cons_pointer p = arg; sequencep( p ); p = c_cdr( p ) ) { + struct cons_space_object o = pointer2cell( p ); + switch ( o.tag.value ) { + case CONSTV: + result = make_cons( o.payload.cons.car, result ); + break; + case STRINGTV: + result = make_string( o.payload.string.character, result ); + break; + case SYMBOLTV: + result = + make_symbol_or_key( o.payload.string.character, result, + SYMBOLTV ); + break; + } } + } else { + result = arg; } return result; @@ -1350,6 +1353,86 @@ struct cons_pointer lisp_source( struct stack_frame *frame, return result; } +/** + * A version of append which can conveniently be called from C. + */ +struct cons_pointer c_append( struct cons_pointer l1, struct cons_pointer l2 ) { + switch ( pointer2cell( l1 ).tag.value ) { + case CONSTV: + if ( pointer2cell( l1 ).tag.value == pointer2cell( l2 ).tag.value ) { + if ( nilp( c_cdr( l1 ) ) ) { + return make_cons( c_car( l1 ), l2 ); + } else { + return make_cons( c_car( l1 ), + c_append( c_cdr( l1 ), l2 ) ); + } + } else { + throw_exception( c_string_to_lisp_string + ( L"Can't append: not same type" ), NIL ); + } + break; + case KEYTV: + case STRINGTV: + case SYMBOLTV: + if ( pointer2cell( l1 ).tag.value == pointer2cell( l2 ).tag.value ) { + if ( nilp( c_cdr( l1 ) ) ) { + return + make_string_like_thing( ( pointer2cell( l1 ).payload. + string.character ), l2, + pointer2cell( l1 ).tag.value ); + } else { + return + make_string_like_thing( ( pointer2cell( l1 ).payload. + string.character ), + c_append( c_cdr( l1 ), l2 ), + pointer2cell( l1 ).tag.value ); + } + } else { + throw_exception( c_string_to_lisp_string + ( L"Can't append: not same type" ), NIL ); + } + break; + default: + throw_exception( c_string_to_lisp_string + ( L"Can't append: not a sequence" ), NIL ); + break; + } +} + +/** + * should really be overwritten with a version in Lisp, since this is much easier to write in Lisp + */ +struct cons_pointer lisp_append( struct stack_frame *frame, + struct cons_pointer frame_pointer, + struct cons_pointer env ) { + return c_append( frame->arg[0], frame->arg[1] ); +} + + +struct cons_pointer lisp_mapcar( struct stack_frame *frame, + struct cons_pointer frame_pointer, + struct cons_pointer env ) { + struct cons_pointer result = NIL; + + for ( struct cons_pointer c = frame->arg[1]; truep( c ); c = c_cdr( c ) ) { + struct cons_pointer expr = make_cons(frame->arg[0], make_cons(c_car(c), NIL)); + inc_ref(expr); + + struct cons_pointer r = eval_form(frame, frame_pointer, expr, env); + + if ( exceptionp( r ) ) { + result = r; + inc_ref( expr ); // to protect exception from the later dec_ref + break; + } else { + result = make_cons( c, result ); + } + + dec_ref( expr ); + } + + return c_reverse( result ); +} // /** // * Function; print the internal representation of the object indicated by `frame->arg[0]` to the diff --git a/src/ops/lispops.h b/src/ops/lispops.h index c1cc337..582cd98 100644 --- a/src/ops/lispops.h +++ b/src/ops/lispops.h @@ -202,4 +202,13 @@ struct cons_pointer lisp_source( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ); +struct cons_pointer c_append( struct cons_pointer l1, struct cons_pointer l2 ); + +struct cons_pointer lisp_append( struct stack_frame *frame, + struct cons_pointer frame_pointer, + struct cons_pointer env ); + +struct cons_pointer lisp_mapcar( struct stack_frame *frame, + struct cons_pointer frame_pointer, + struct cons_pointer env ); #endif diff --git a/src/ops/loop.c b/src/ops/loop.c new file mode 100644 index 0000000..6ccada6 --- /dev/null +++ b/src/ops/loop.c @@ -0,0 +1,50 @@ +/* + * loop.c + * + * Iteration functions. This has *a lot* of similarity to try/catch -- + * essentially what `recur` does is throw a special purpose exception which is + * caught by `loop`. + * + * Essentially the syntax I want is + * + * (defun expt (n e) + * (loop ((n1 . n) (r . n) (e1 . e)) + * (cond ((= e 0) r) + * (t (recur n1 (* n1 r) (- e 1))))) + * + * It might in future be good to allow the body of the loop to comprise many + * expressions, like a `progn`, but for now if you want that you can just + * shove a `progn` in. Note that, given that what `recur` is essentially + * doing is throwing a special purpose exception, the `recur` expression + * doesn't actually have to be in the same function as the `loop` expression. + * + * (c) 2021 Simon Brooke + * Licensed under GPL version 2.0, or, at your option, any later version. + */ + +#include "consspaceobject.h" +#include "lispops.h" +#include "loop.h" + +/** + * Special form, not dissimilar to `let`. Essentially, + * + * 1. the first arg (`args`) is an assoc list; + * 2. the second arg (`body`) is an expression. + * + * Each of the vals in the assoc list is evaluated, and bound to its + * respective key in a new environment. The body is then evaled in that + * environment. If the result is an object of type LOOP, it should carry + * a list of values of the same arity as args. Each of the keys in args + * is then rebound in a new environment to the respective value from the + * LOOP object, and body is then re-evaled in that environment. + * + * If the result is not a LOOP object, it is simply returned. + */ +struct cons_pointer +lisp_loop( struct stack_frame *frame, struct cons_pointer frame_pointer, + struct cons_pointer env ) { + struct cons_pointer keys = c_keys( frame->arg[0] ); + struct cons_pointer body = frame->arg[1]; + +} diff --git a/src/ops/loop.h b/src/ops/loop.h new file mode 100644 index 0000000..27714a8 --- /dev/null +++ b/src/ops/loop.h @@ -0,0 +1,10 @@ +/* + * loop.h + * + * Iteration functions. This has *a lot* of similarity to try/catch -- + * essentially what `recur` does is throw a special purpose exception which is + * caught by `loop`. + * + * (c) 2021 Simon Brooke + * Licensed under GPL version 2.0, or, at your option, any later version. + */ diff --git a/unit-tests/append.sh b/unit-tests/append.sh new file mode 100755 index 0000000..0f6fb30 --- /dev/null +++ b/unit-tests/append.sh @@ -0,0 +1,24 @@ +#!/bin/bash + +expected='(a b c d e f)' +actual=`echo "(append '(a b c) '(d e f))" | target/psse | tail -1` + +if [ "${expected}" = "${actual}" ] +then + echo "OK" +else + echo "Fail: expected '${expected}', got '${actual}'" + exit 1 +fi + +expected='"hellodere"' +actual=`echo '(append "hello" "dere")' | target/psse | tail -1` + +if [ "${expected}" = "${actual}" ] +then + echo "OK" +else + echo "Fail: expected '${expected}', got '${actual}'" + exit 1 +fi + From 4047b88cae2d5fe2a482d6a3722355fc966a3342 Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Mon, 23 Aug 2021 13:29:11 +0100 Subject: [PATCH 17/28] Documentation, only --- README.md | 135 +++++++++++++++++++++++++++++++++++++++++++++++++++++- 1 file changed, 133 insertions(+), 2 deletions(-) diff --git a/README.md b/README.md index 9c08aab..afcc524 100644 --- a/README.md +++ b/README.md @@ -1,7 +1,5 @@ # Post Scarcity Software System, version 0 -Very Nearly a Big Lisp Environment - tl,dr: look at the [wiki](wiki). ## State of play @@ -22,6 +20,139 @@ What I'm trying to do now is write a detailed low level specification of the und Although I describe it as a 'Lisp environment', for reasons explained in Post Scarcity Software that doesn't mean you will program it in Lisp. It means that the underlying representation of things in the system is Lispy, not Unixy. +## Bindings currently available + +The following symbols are bound in the bootstrap layer. It is anticipated that + +1. Most of the functions will be overridden by versions of the same function written in Lisp; but +2. these implementations will remain available in the package `/:bootstrap`. + +### Values + +Note that symbols delimited by asterisks, as in `*in*`, invite rebinding; it is expected, for example, that users will want to rebind input and output streams in their current environment. Rebinding some other symbols, for example `nil`, is unwise. + +#### nil + +The canonical empty list. + +#### t + +The canonical true value. + +#### \*in\* + +The input stream. + +#### \*out\* + +The output stream. + +#### \*log\* + +The logging stream (equivalent to `stderr`). + +#### \*sink\* + +The sink stream (equivalent to `/dev/null`). + +#### \*prompt\* + +The REPL prompt. + +#### (absolute *n*) + +Return the absolute value of a number. + +#### (add *n1* *n2* ...), (+ *n1* *n2* ...) + +Return the result of adding together all the (assumed numeric) arguments supplied. + +#### (append *s1* *s2*) + +Return a new sequence comprising all the elements of *s1* followed by all the elements of *s2*. *s1* and *s2* must be sequences of the same type. At a later stage this function will accept arbitrary numbers of arguments, but by that time it will be written in Lisp. + +#### (apply *f* *s*) + +Apply the function *f* to the arguments that form the sequence *s*, and return the result. + +#### (assoc *key* *store*) + +Return the value associated with *key* in *store*. *key* may be an object of any type, but keywords, symbols and strings are handled most efficiently. *store* may be an [*association list*](#Association_list), or may be a hashmap. + +#### (car *s*) + +Return the first element of the sequence *s*. + +#### (cdr *s*) + +Return a sequence of all the elements of the sequence *s* except the first. + +#### (close *stream*) + +Closes the indicates stream. Returns `nil`. + +#### (cons *a* *b*) + +Returns a new pair comprising *a* and *b*. If *b* is a list, this has the effect of creating a new list with the element *a* prepended to all the elements of *b*. If *b* is `nil`, this has the effect creating a new list with *a* as the sole element. Otherwise, it just creates a pair. + +#### (divide *n1* *n2*), (/ *n1* *n2*) + +Divides the number *n1* by the number *n2*. If *n1* and *n2* are both integers, it's likely that the result will be a rational number. + +#### (eq *o1* *o2*) + +Returns true (`t`) if *o1* and *o2* are identically the same object, else `nil`. + +#### (equal *o1* *o2*) + +Returns true (`t`) if *o1* and *o2* are structurally identical to one another, else `nil`. + +#### (exception *message*) + +Throws (returns) an exception, with the specified *message*. Note that it is extremely likely this signature will change. + +#### (get-hash *key* *hashmap*) + +Like 'assoc', but the store must be a hashmap. Deprecated. + +#### (hashmap *n* *f* *store*) + +Create a hashmap with *n* buckets, using *f* as its hashing function, and initialised with the key/value pairs from *store*. All arguments are optional; if none are passed, will create an empty hashmap with 32 keys and the default hashing function. + +#### (inspect *o*) + +Prints detailed structure of the object *o*. Primarily for debugging. + +#### (keys *store*) + +Returns a list of the keys in *store*, which may be either an [*association list*](#Association_list), or a hashmap. + +#### (mapcar *f* *s*) + +Applies the function *f* to each element of the sequence *s*, and returns a new sequence of the results. + +#### (meta *o*), (metadata *o*) + +Returns metadata on *o*. + +#### (multiply *n1* *n2* ...), (\* *n1* *n2* ...) + +Returns the product of multiplying together all of its numeric arguments. + +#### (negative? n1) + +Returns `t` if its argument is a negative number, else `nil`. + +#### (oblist) + +Returns a sequence of all the names bound in the root of the naming system. + +#### (open *url* *read?*) + +Opens a stream to the specified *url*. If a second argument is present and is non-`nil`, the stream is opened for reading; otherwise, it's opened for writing. + + + ## License Copyright © 2017 [Simon Brooke](mailto:simon@journeyman.cc) From 06e87f09faedc8c370cd473f73b2f1dc2a2d47c4 Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Wed, 8 Sep 2021 13:12:40 +0100 Subject: [PATCH 18/28] Mapcar working; really only `let` left to do for version 0.1 --- src/ops/lispops.c | 31 +++++++++++++++++++++++++------ 1 file changed, 25 insertions(+), 6 deletions(-) diff --git a/src/ops/lispops.c b/src/ops/lispops.c index 2356abe..0f058ed 100644 --- a/src/ops/lispops.c +++ b/src/ops/lispops.c @@ -42,8 +42,6 @@ * also to create in this section: * struct cons_pointer lisp_let( struct cons_pointer args, struct cons_pointer env, * struct stack_frame* frame); - * struct cons_pointer lisp_mapcar( struct cons_pointer args, struct cons_pointer env, - * struct stack_frame* frame); * * and others I haven't thought of yet. */ @@ -62,7 +60,8 @@ struct cons_pointer eval_form( struct stack_frame *parent, struct cons_pointer form, struct cons_pointer env ) { debug_print( L"eval_form: ", DEBUG_EVAL ); - debug_dump_object( form, DEBUG_EVAL ); + debug_print_object( form, DEBUG_EVAL ); + debug_println(DEBUG_EVAL); struct cons_pointer result = NIL; struct cons_pointer next_pointer = make_empty_frame( parent_pointer ); @@ -81,6 +80,10 @@ struct cons_pointer eval_form( struct stack_frame *parent, dec_ref( next_pointer ); } + debug_print( L"eval_form returning: ", DEBUG_EVAL ); + debug_print_object( result, DEBUG_EVAL ); + debug_println(DEBUG_EVAL); + return result; } @@ -1413,25 +1416,41 @@ struct cons_pointer lisp_mapcar( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ) { struct cons_pointer result = NIL; + debug_print( L"Mapcar: ", DEBUG_EVAL ); + debug_dump_object( frame_pointer, DEBUG_EVAL ); + int i = 0; for ( struct cons_pointer c = frame->arg[1]; truep( c ); c = c_cdr( c ) ) { struct cons_pointer expr = make_cons(frame->arg[0], make_cons(c_car(c), NIL)); inc_ref(expr); - struct cons_pointer r = eval_form(frame, frame_pointer, expr, env); + debug_printf(DEBUG_EVAL, L"Mapcar %d, evaluating ", i); + debug_print_object( expr, DEBUG_EVAL); + debug_println(DEBUG_EVAL); + + struct cons_pointer r = eval_form(frame, frame_pointer, expr, env); if ( exceptionp( r ) ) { result = r; inc_ref( expr ); // to protect exception from the later dec_ref break; } else { - result = make_cons( c, result ); + result = make_cons( r, result ); } + debug_printf(DEBUG_EVAL, L"Mapcar %d, result is ", i++); + debug_print_object( result, DEBUG_EVAL); + debug_println(DEBUG_EVAL); dec_ref( expr ); } - return c_reverse( result ); + result = consp(result) ? c_reverse( result ) : result; + + debug_print( L"Mapcar returning: ", DEBUG_EVAL ); + debug_print_object( result, DEBUG_EVAL ); + debug_println(DEBUG_EVAL); + + return result; } // /** From 3abebe937cd55436e8d1bb8c9d1db741317a39b6 Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Wed, 8 Sep 2021 13:47:36 +0100 Subject: [PATCH 19/28] Added `list` and unit test for it. --- src/init.c | 1 + src/ops/lispops.c | 13 +++++++++++ src/ops/lispops.h | 4 ++++ unit-tests/integer-allocation.sh | 4 ++-- unit-tests/list-test,sh | 38 ++++++++++++++++++++++++++++++++ 5 files changed, 58 insertions(+), 2 deletions(-) create mode 100644 unit-tests/list-test,sh diff --git a/src/init.c b/src/init.c index 5e8a55d..4fc922a 100644 --- a/src/init.c +++ b/src/init.c @@ -236,6 +236,7 @@ int main( int argc, char *argv[] ) { bind_function( L"hashmap", lisp_make_hashmap ); bind_function( L"inspect", &lisp_inspect ); bind_function( L"keys", &lisp_keys ); + bind_function( L"list", &lisp_list); bind_function( L"mapcar", &lisp_mapcar ); bind_function( L"meta", &lisp_metadata ); bind_function( L"metadata", &lisp_metadata ); diff --git a/src/ops/lispops.c b/src/ops/lispops.c index 0f058ed..d35c5a6 100644 --- a/src/ops/lispops.c +++ b/src/ops/lispops.c @@ -1453,6 +1453,19 @@ struct cons_pointer lisp_mapcar( struct stack_frame *frame, return result; } +struct cons_pointer lisp_list( struct stack_frame *frame, + struct cons_pointer frame_pointer, + struct cons_pointer env ) { + struct cons_pointer result = frame->more; + + for ( int a = nilp(result) ? frame->args - 1: args_in_frame - 1; + a >= 0; a-- ) { + result = make_cons(fetch_arg(frame, a), result); + } + + return result; +} + // /** // * Function; print the internal representation of the object indicated by `frame->arg[0]` to the // * (optional, defaults to the value of `*out*` in the environment) stream indicated by `frame->arg[1]`. diff --git a/src/ops/lispops.h b/src/ops/lispops.h index 582cd98..2724f89 100644 --- a/src/ops/lispops.h +++ b/src/ops/lispops.h @@ -211,4 +211,8 @@ struct cons_pointer lisp_append( struct stack_frame *frame, struct cons_pointer lisp_mapcar( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ); + + struct cons_pointer lisp_list( struct stack_frame *frame, + struct cons_pointer frame_pointer, + struct cons_pointer env ); #endif diff --git a/unit-tests/integer-allocation.sh b/unit-tests/integer-allocation.sh index ced92f2..b25bef3 100755 --- a/unit-tests/integer-allocation.sh +++ b/unit-tests/integer-allocation.sh @@ -1,8 +1,8 @@ #!/bin/bash value=354 -expected="Integer cell: value ${value}," -echo ${value} | target/psse -v5 2>&1 | grep "${expected}" > /dev/null +expected="(${value} \"INTR\")" +echo "(set! x $value)(list x (type x))" | target/psse 2>&1 | grep "${expected}" > /dev/null if [ $? -eq 0 ] then diff --git a/unit-tests/list-test,sh b/unit-tests/list-test,sh new file mode 100644 index 0000000..32f4797 --- /dev/null +++ b/unit-tests/list-test,sh @@ -0,0 +1,38 @@ +#!/bin/bash + +expected="(0 1 2 3 4 5 6 7 8 9 a b c d e f)" + +actual=`echo "(list 0 1 2 3 4 5 6 7 8 9 'a 'b 'c 'd 'e 'f)" | target/psse | tail -1` + +if [ "${expected}" = "${actual}" ] +then + echo "OK" +else + echo "Fail: expected '$expected', got '$actual'" + exit 1 +fi + +expected="(0 1 2 3 4)" + +actual=`echo "(list 0 1 2 3 4)" | target/psse | tail -1` + +if [ "${expected}" = "${actual}" ] +then + echo "OK" +else + echo "Fail: expected '$expected', got '$actual'" + exit 1 +fi + +expected="(0 1 2 3 4 5 6 7)" + +actual=`echo "(list 0 1 2 3 4 5 6 7)" | target/psse | tail -1` + +if [ "${expected}" = "${actual}" ] +then + echo "OK" + exit 0 +else + echo "Fail: expected '$expected', got '$actual'" + exit 1 +fi From 78d2395d60b291737a70fc83ee165b63f1462bff Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Wed, 8 Sep 2021 15:01:48 +0100 Subject: [PATCH 20/28] Let working, unit tested. --- src/init.c | 1 + src/ops/lispops.c | 54 ++++++++++++++++++++++++++++++++++++++++++----- src/ops/lispops.h | 4 ++++ unit-tests/let.sh | 24 +++++++++++++++++++++ 4 files changed, 78 insertions(+), 5 deletions(-) create mode 100755 unit-tests/let.sh diff --git a/src/init.c b/src/init.c index 4fc922a..031d0ba 100644 --- a/src/init.c +++ b/src/init.c @@ -270,6 +270,7 @@ int main( int argc, char *argv[] ) { bind_special( L"cond", &lisp_cond ); bind_special( L"lambda", &lisp_lambda ); bind_special( L"\u03bb", &lisp_lambda ); // λ + bind_special(L"let", &lisp_let); bind_special( L"nlambda", &lisp_nlambda ); bind_special( L"n\u03bb", &lisp_nlambda ); bind_special( L"progn", &lisp_progn ); diff --git a/src/ops/lispops.c b/src/ops/lispops.c index d35c5a6..fa3c68d 100644 --- a/src/ops/lispops.c +++ b/src/ops/lispops.c @@ -593,7 +593,7 @@ lisp_set( struct stack_frame *frame, struct cons_pointer frame_pointer, result = frame->arg[1]; } else { result = - make_exception( make_cons + throw_exception( make_cons ( c_string_to_lisp_string ( L"The first argument to `set` is not a symbol: " ), make_cons( frame->arg[0], NIL ) ), @@ -632,7 +632,7 @@ lisp_set_shriek( struct stack_frame *frame, struct cons_pointer frame_pointer, result = val; } else { result = - make_exception( make_cons + throw_exception( make_cons ( c_string_to_lisp_string ( L"The first argument to `set!` is not a symbol: " ), make_cons( frame->arg[0], NIL ) ), @@ -1212,7 +1212,7 @@ struct cons_pointer lisp_exception( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ) { struct cons_pointer message = frame->arg[0]; - return exceptionp( message ) ? message : make_exception( message, + return exceptionp( message ) ? message : throw_exception( message, frame->previous ); } @@ -1408,9 +1408,14 @@ struct cons_pointer c_append( struct cons_pointer l1, struct cons_pointer l2 ) { struct cons_pointer lisp_append( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ) { - return c_append( frame->arg[0], frame->arg[1] ); -} + struct cons_pointer result = fetch_arg(frame, (frame->args - 1)); + for (int a = frame->args - 2; a >= 0; a--) { + result = c_append(fetch_arg(frame, a), result); + } + + return result; +} struct cons_pointer lisp_mapcar( struct stack_frame *frame, struct cons_pointer frame_pointer, @@ -1466,6 +1471,45 @@ struct cons_pointer lisp_list( struct stack_frame *frame, return result; } +/** + * Special form: evaluate a series of forms in an environment in which + * these bindings are bound. + * This is `let*` in Common Lisp parlance; `let` in Clojure parlance. + */ +struct cons_pointer lisp_let( struct stack_frame *frame, + struct cons_pointer frame_pointer, + struct cons_pointer env) { + struct cons_pointer bindings = env; + struct cons_pointer result = NIL; + + for (struct cons_pointer cursor = frame->arg[0]; + truep(cursor); + cursor = c_cdr(cursor)) { + struct cons_pointer pair = c_car(cursor); + struct cons_pointer symbol = c_car(pair); + + if (symbolp(symbol)) { + bindings = make_cons( + make_cons(symbol, eval_form(frame, frame_pointer, c_cdr(pair), bindings)), + bindings); + + } else { + result = throw_exception( + c_string_to_lisp_string(L"Let: cannot bind, not a symbol"), + frame_pointer); + break; + } + } + + /* i.e., no exception yet */ + for (int form = 1; !exceptionp(result) && form < frame->args; form++) { + result = eval_form(frame, frame_pointer, fetch_arg(frame, form), bindings); + } + + return result; + + } + // /** // * Function; print the internal representation of the object indicated by `frame->arg[0]` to the // * (optional, defaults to the value of `*out*` in the environment) stream indicated by `frame->arg[1]`. diff --git a/src/ops/lispops.h b/src/ops/lispops.h index 2724f89..3d1c4f7 100644 --- a/src/ops/lispops.h +++ b/src/ops/lispops.h @@ -215,4 +215,8 @@ struct cons_pointer lisp_mapcar( struct stack_frame *frame, struct cons_pointer lisp_list( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ); + +struct cons_pointer lisp_let( struct stack_frame *frame, + struct cons_pointer frame_pointer, + struct cons_pointer env); #endif diff --git a/unit-tests/let.sh b/unit-tests/let.sh new file mode 100755 index 0000000..6454b1e --- /dev/null +++ b/unit-tests/let.sh @@ -0,0 +1,24 @@ +#!/bin/bash + +expected='11' +actual=`echo "(let ((a . 5)(b . 6)) (+ a b))" | target/psse | tail -1` + +if [ "${expected}" = "${actual}" ] +then + echo "OK" +else + echo "Fail: expected '$expected', got '$actual'" + exit 1 +fi + +expected='1' +actual=`echo "(let ((a . 5)(b . 6)) (+ a b) (- b a))" | target/psse | tail -1` + +if [ "${expected}" = "${actual}" ] +then + echo "OK" + exit 0 +else + echo "Fail: expected '$expected', got '$actual'" + exit 1 +fi From be5cc4e528d024c00386960cde2139648bb9dd4a Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Wed, 8 Sep 2021 18:32:31 +0100 Subject: [PATCH 21/28] Documentation in README.md --- README.md | 136 ++++++++++++++++++++++++++++++++++++++++++++++++++++-- 1 file changed, 132 insertions(+), 4 deletions(-) diff --git a/README.md b/README.md index afcc524..408818c 100644 --- a/README.md +++ b/README.md @@ -4,6 +4,28 @@ tl,dr: look at the [wiki](wiki). ## State of play +### Version 0.0.5 + +Has working Lisp interpreter, more or less complete, with functions and symbols as defined under [[#Bindings currently available]] below. Features include hash maps. + +#### Known bugs + +At the time of writing, big number arithmetic is completely failing. It has worked in the past, but it doesn't now. + +#### Unknown bugs + +It's pretty likely that there are memory leaks. + +#### Not yet implemented + +1. There is as yet no **compiler**, and indeed it isn't yet certain what a compiler would even mean. Do all nodes in a machine necessarily share the same processor architecture? +2. There's the beginnings of a narrative about how **namespaces** are going to work, but as yet they aren't really implemented. +3. There is as yet no implementation of the concept of **users**. Access Control Lists exist but are not used. Related, there's no concept of a **session**. +4. There is as yet no **multiprocessor architecture**, not even a simulated one. As it is intended that threading will be implemented by handing off parts of a computation to peer processors, this means there no **threads** either. +5. There's no **user interface** beyond a REPL. There isn't even an **editor**, or **history**. +6. **Printing to strings** does not work. +7. The **exception system**, while it does exist, needs to be radically rethought. + ### Version 0.0.4 Has working rational number arithmetic, as well as integer and real number arithmetic. The stack is now in vector space, but vector space is not yet properly garbage collected. `defun` does not yet work, so although Lisp functions can be defined the syntax is pretty clunky. So you *can* start to do things with this, but you should probably wait for at least a 0.1.0 release! @@ -25,7 +47,7 @@ Although I describe it as a 'Lisp environment', for reasons explained in Post Sc The following symbols are bound in the bootstrap layer. It is anticipated that 1. Most of the functions will be overridden by versions of the same function written in Lisp; but -2. these implementations will remain available in the package `/:bootstrap`. +2. these implementations will remain available in the namespace `/:bootstrap`. ### Values @@ -59,6 +81,8 @@ The sink stream (equivalent to `/dev/null`). The REPL prompt. +### Functions + #### (absolute *n*) Return the absolute value of a number. @@ -67,9 +91,9 @@ Return the absolute value of a number. Return the result of adding together all the (assumed numeric) arguments supplied. -#### (append *s1* *s2*) +#### (append *s1* *s2* ...) -Return a new sequence comprising all the elements of *s1* followed by all the elements of *s2*. *s1* and *s2* must be sequences of the same type. At a later stage this function will accept arbitrary numbers of arguments, but by that time it will be written in Lisp. +Return a new sequence comprising all the elements of *s1* followed by all the elements of *s2* and so on for an indefinite number of arguments. All arguments must be sequences of the same type. #### (apply *f* *s*) @@ -109,7 +133,7 @@ Returns true (`t`) if *o1* and *o2* are structurally identical to one another, e #### (exception *message*) -Throws (returns) an exception, with the specified *message*. Note that it is extremely likely this signature will change. +Throws (returns) an exception, with the specified *message*. Note that this doesn't really work at all well, and that it is extremely likely this signature will change. #### (get-hash *key* *hashmap*) @@ -127,6 +151,14 @@ Prints detailed structure of the object *o*. Primarily for debugging. Returns a list of the keys in *store*, which may be either an [*association list*](#Association_list), or a hashmap. +#### (let *bindings* *form*...) + +Evaluates each of the *forms* in an environment to which ally of these *bindings* have been added. *bindings* must be an [*association list*](#Association_list), and, additionally, all keys in *bindings* must be symbols. Values in the association list will be evaluated before being bound, and this is done sequentially, as in the behaviour of Common Lisp `let*` rather than of Common Lisp `let`. + +#### (list *o*...) + +Returns a list of the values of all of its arguments in sequence. + #### (mapcar *f* *s*) Applies the function *f* to each element of the sequence *s*, and returns a new sequence of the results. @@ -151,6 +183,102 @@ Returns a sequence of all the names bound in the root of the naming system. Opens a stream to the specified *url*. If a second argument is present and is non-`nil`, the stream is opened for reading; otherwise, it's opened for writing. +### Types + +The following types are known. Further types can be defined, and ultimately it should be possible to define further types in Lisp, but these are what you have to be going on with. Note that where this documentation differs from `memory/consspaceobject.h`, this documentation is *wrong*. + +#### CONS + +An ordinary cons cell: that is to say, a pair. + +#### EXEP + +An exception + +#### FREE + +An unallocated memory cell. User programs should never see this. + +#### FUNC + +A primitive or compiled Lisp function \-- one whose arguments are pre-evaluated. + +#### HASH + +A hash map (in vector space) + +#### INTR + +An arbitrarily large integer number. + +#### KEYW + +A keyword - an interned, self-evaluating string. + +#### LMBA + +A lambda cell. Lambdas are the interpretable (source) versions of functions. + +#### LOOP + +Internal to the workings of the ••loop** function. User functions should never see this. + +#### NIL + +The special cons cell at address {0,0} whose **car** and **cdr** both point to itself. The canonical empty set. Generally, treated as being indicative of falsity. + +#### NLMD + +An nlambda cell. NLambdas are the interpretable (source) versions of special forms. + +#### RTIO + +A rational number, stored as pointers two integers representing dividend and divisor respectively. + +#### READ + +An open read stream. + +#### REAL + +A real number, represented internally as an IEEE 754-2008 `binary64`. + +#### SPFM + +A compiled or primitive special form - one whose arguments are not pre-evaluated but passed as provided. + +#### STAK + +A stack frame. In vector space. + +#### STRG + +A string of [UTF-32](https://en.wikipedia.org/wiki/UTF-32) characters, stored as a linked list. Self evaluating. + +#### SYMB + +A symbol is just like a string except not self-evaluating. Later, there may be some restrictions on what characters are legal in a symbol, but at present there are not. + +#### TIME + +A time stamp. Not really properly implemented yet; the epoch is not defined, and, given the size of numbers we can store, could be pushed far into the past. + +#### TRUE + +The special cell at address {0,1} which is canonically different from NIL. + +#### VECP + +A pointer to an object in vector space. User functions shouldn't see this, they should see the type of the vector-space object indicated. + +#### VECT + +A vector of objects. In vector space. + +#### WRIT + +An open write stream. + ## License From 2c96e7c30d8d152b4bc5fb88770c0a8e37348975 Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Sun, 12 Sep 2021 13:41:27 +0100 Subject: [PATCH 22/28] Sanitising debug-printf formats, mostly. --- .gitignore | 4 ++++ Makefile | 2 +- src/arith/integer.c | 2 +- src/init.c | 1 + src/io/io.c | 1 + src/memory/conspage.c | 15 ++++++++++++++- src/memory/conspage.h | 2 ++ src/memory/consspaceobject.c | 2 +- src/memory/vectorspace.c | 2 +- 9 files changed, 26 insertions(+), 5 deletions(-) diff --git a/.gitignore b/.gitignore index a85ac01..b07b2a6 100644 --- a/.gitignore +++ b/.gitignore @@ -42,3 +42,7 @@ hi\.* .vscode/ core + +.kdev4/ + +post-scarcity.kdev4 diff --git a/Makefile b/Makefile index d8e6e81..7e5efb4 100644 --- a/Makefile +++ b/Makefile @@ -3,7 +3,7 @@ SRC_DIRS ?= ./src SRCS := $(shell find $(SRC_DIRS) -name *.cpp -or -name *.c -or -name *.s) HDRS := $(shell find $(SRC_DIRS) -name *.h) -OBJS := $(addsuffix .o,$(basename $(SRCS))) +OBJS := $(addsuffix .o,$(basename $(SRCS))) DEPS := $(OBJS:.o=.d) TESTS := $(shell find unit-tests -name *.sh) diff --git a/src/arith/integer.c b/src/arith/integer.c index db486d2..06ef8a3 100644 --- a/src/arith/integer.c +++ b/src/arith/integer.c @@ -76,7 +76,7 @@ __int128_t cell_value( struct cons_pointer c, char op, bool is_first_cell ) { __int128_t result = ( __int128_t ) integerp( c ) ? ( val == 0 ) ? carry : val : op == '*' ? 1 : 0; debug_printf( DEBUG_ARITH, - L"cell_value: raw value is %ld, is_first_cell = %s; %4.4s; returning ", + L"cell_value: raw value is %ld, is_first_cell = %s; '%4.4s'; returning ", val, is_first_cell ? "true" : "false", pointer2cell( c ).tag.bytes ); debug_print_128bit( result, DEBUG_ARITH ); diff --git a/src/init.c b/src/init.c index 031d0ba..a47f008 100644 --- a/src/init.c +++ b/src/init.c @@ -288,6 +288,7 @@ int main( int argc, char *argv[] ) { dump_pages( file_to_url_file( stdout ) ); } + summarise_allocation(); curl_global_cleanup( ); return ( 0 ); } diff --git a/src/io/io.c b/src/io/io.c index 72830a4..fe08a77 100644 --- a/src/io/io.c +++ b/src/io/io.c @@ -166,6 +166,7 @@ wint_t url_fgetwc( URL_FILE * input ) { debug_print( L"url_fgetwc: back from url_fgets\n", DEBUG_IO ); int c = ( int ) cbuff[0]; + // TODO: risk of reading off cbuff? debug_printf( DEBUG_IO, L"url_fgetwc: cbuff is '%s'; (first) character = %d (%c)\n", cbuff, c, c & 0xf7 ); diff --git a/src/memory/conspage.c b/src/memory/conspage.c index d8d54f9..f967c74 100644 --- a/src/memory/conspage.c +++ b/src/memory/conspage.c @@ -28,6 +28,12 @@ */ bool conspageinitihasbeencalled = false; +/** + * keep track of total cells allocated and freed to check for leakage. + */ +uint64_t total_cells_allocated = 0; +uint64_t total_cells_freed = 0; + /** * the number of cons pages which have thus far been initialised. */ @@ -187,6 +193,7 @@ void free_cell( struct cons_pointer pointer ) { cell->payload.free.car = NIL; cell->payload.free.cdr = freelist; freelist = pointer; + total_cells_freed ++; } else { debug_printf( DEBUG_ALLOC, L"ERROR: Attempt to free cell with %d dangling references at page %d, offset %d\n", @@ -228,8 +235,10 @@ struct cons_pointer allocate_cell( uint32_t tag ) { cell->payload.cons.car = NIL; cell->payload.cons.cdr = NIL; + total_cells_allocated ++; + debug_printf( DEBUG_ALLOC, - L"Allocated cell of type '%s' at %d, %d \n", tag, + L"Allocated cell of type '%4.4s' at %d, %d \n", tag, result.page, result.offset ); } else { debug_printf( DEBUG_ALLOC, L"WARNING: Allocating non-free cell!" ); @@ -255,3 +264,7 @@ void initialise_cons_pages( ) { L"WARNING: initialise_cons_pages() called a second or subsequent time\n" ); } } + +void summarise_allocation() { + fwprintf(stderr, L"Allocation summary: allocated %lld; deallocated %lld.\n", total_cells_allocated, total_cells_freed ); +} \ No newline at end of file diff --git a/src/memory/conspage.h b/src/memory/conspage.h index 260794e..18eda3b 100644 --- a/src/memory/conspage.h +++ b/src/memory/conspage.h @@ -61,4 +61,6 @@ void initialise_cons_pages( ); void dump_pages( URL_FILE * output ); +void summarise_allocation(); + #endif diff --git a/src/memory/consspaceobject.c b/src/memory/consspaceobject.c index 5b04699..0eef3d5 100644 --- a/src/memory/consspaceobject.c +++ b/src/memory/consspaceobject.c @@ -324,7 +324,7 @@ make_string_like_thing( wint_t c, struct cons_pointer tail, uint32_t tag ) { } else { // \todo should throw an exception! debug_printf( DEBUG_ALLOC, - L"Warning: only NIL and %s can be prepended to %s\n", + L"Warning: only NIL and %4.4s can be prepended to %4.4s\n", tag, tag ); } diff --git a/src/memory/vectorspace.c b/src/memory/vectorspace.c index 4709482..0c1b159 100644 --- a/src/memory/vectorspace.c +++ b/src/memory/vectorspace.c @@ -85,7 +85,7 @@ struct cons_pointer make_vso( uint32_t tag, uint64_t payload_size ) { if ( vso != NULL ) { memset( vso, 0, padded ); debug_printf( DEBUG_ALLOC, - L"make_vso: about to write tag '%s' into vso at %p\n", + L"make_vso: about to write tag '%4.4s' into vso at %p\n", tag, vso ); vso->header.tag.value = tag; result = make_vec_pointer( vso, tag ); From 2b8f31d2ce46a9bd475dd7063366a1c0b956eb10 Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Sun, 12 Sep 2021 15:02:27 +0100 Subject: [PATCH 23/28] Paths of #include files --- src/arith/integer.c | 10 +++++----- src/arith/peano.c | 24 ++++++++++++------------ src/arith/ratio.c | 16 ++++++++-------- src/arith/real.c | 6 +++--- src/debug.c | 8 ++++---- src/init.c | 22 ++++++++++++---------- src/io/fopen.c | 6 +++--- src/io/io.c | 14 ++++++-------- src/io/print.c | 18 +++++++++--------- src/io/read.c | 36 ++++++++++++++++++++---------------- src/memory/conspage.c | 12 ++++++------ src/memory/consspaceobject.c | 12 ++++++------ src/memory/dump.c | 16 ++++++++-------- src/memory/hashmap.c | 2 +- src/memory/stack.c | 14 +++++++------- src/memory/vectorspace.c | 10 +++++----- src/ops/intern.c | 10 +++++----- src/ops/lispops.c | 24 ++++++++++++------------ src/ops/meta.c | 2 +- src/repl.c | 8 ++++---- src/time/psse_time.c | 9 ++++----- 21 files changed, 141 insertions(+), 138 deletions(-) diff --git a/src/arith/integer.c b/src/arith/integer.c index 06ef8a3..eef171b 100644 --- a/src/arith/integer.c +++ b/src/arith/integer.c @@ -18,12 +18,12 @@ #include #include -#include "conspage.h" -#include "consspaceobject.h" +#include "memory/conspage.h" +#include "memory/consspaceobject.h" #include "debug.h" -#include "equal.h" -#include "lispops.h" -#include "peano.h" +#include "ops/equal.h" +#include "ops/lispops.h" +#include "arith/peano.h" /** * hexadecimal digits for printing numbers. diff --git a/src/arith/peano.c b/src/arith/peano.c index 5589f1f..ae23a00 100644 --- a/src/arith/peano.c +++ b/src/arith/peano.c @@ -14,19 +14,19 @@ #include #include -#include "consspaceobject.h" -#include "conspage.h" +#include "memory/consspaceobject.h" +#include "memory/conspage.h" #include "debug.h" -#include "equal.h" -#include "integer.h" -#include "intern.h" -#include "lispops.h" -#include "peano.h" -#include "print.h" -#include "ratio.h" -#include "read.h" -#include "real.h" -#include "stack.h" +#include "ops/equal.h" +#include "arith/integer.h" +#include "ops/intern.h" +#include "ops/lispops.h" +#include "arith/peano.h" +#include "io/print.h" +#include "arith/ratio.h" +#include "io/read.h" +#include "arith/real.h" +#include "memory/stack.h" long double to_long_double( struct cons_pointer arg ); int64_t to_long_int( struct cons_pointer arg ); diff --git a/src/arith/ratio.c b/src/arith/ratio.c index 8100ec2..5135d6b 100644 --- a/src/arith/ratio.c +++ b/src/arith/ratio.c @@ -11,15 +11,15 @@ #include #include -#include "conspage.h" -#include "consspaceobject.h" +#include "memory/conspage.h" +#include "memory/consspaceobject.h" #include "debug.h" -#include "equal.h" -#include "integer.h" -#include "lispops.h" -#include "peano.h" -#include "print.h" -#include "ratio.h" +#include "ops/equal.h" +#include "arith/integer.h" +#include "ops/lispops.h" +#include "arith/peano.h" +#include "io/print.h" +#include "arith/ratio.h" /** diff --git a/src/arith/real.c b/src/arith/real.c index a59a125..34d29d0 100644 --- a/src/arith/real.c +++ b/src/arith/real.c @@ -7,10 +7,10 @@ * Licensed under GPL version 2.0, or, at your option, any later version. */ -#include "conspage.h" -#include "consspaceobject.h" +#include "memory/conspage.h" +#include "memory/consspaceobject.h" #include "debug.h" -#include "read.h" +#include "io/read.h" /** * Allocate a real number cell representing this value and return a cons diff --git a/src/debug.c b/src/debug.c index c8b9771..233e154 100644 --- a/src/debug.c +++ b/src/debug.c @@ -18,11 +18,11 @@ #include #include -#include "consspaceobject.h" +#include "memory/consspaceobject.h" #include "debug.h" -#include "dump.h" -#include "io.h" -#include "print.h" +#include "memory/dump.h" +#include "io/io.h" +#include "io/print.h" /** * the controlling flags for `debug_print`; set in `init.c`, q.v. diff --git a/src/init.c b/src/init.c index a47f008..12187fd 100644 --- a/src/init.c +++ b/src/init.c @@ -20,18 +20,20 @@ #include #include "version.h" -#include "conspage.h" -#include "consspaceobject.h" +#include "memory/conspage.h" +#include "memory/consspaceobject.h" +#include "memory/stack.h" #include "debug.h" -#include "hashmap.h" -#include "intern.h" -#include "io.h" -#include "lispops.h" -#include "meta.h" -#include "peano.h" -#include "print.h" +#include "memory/hashmap.h" +#include "ops/intern.h" +#include "io/io.h" +#include "ops/lispops.h" +#include "ops/meta.h" +#include "arith/peano.h" +#include "io/print.h" #include "repl.h" -#include "psse_time.h" +#include "io/fopen.h" +#include "time/psse_time.h" // extern char *optarg; /* defined in unistd.h */ diff --git a/src/io/fopen.c b/src/io/fopen.c index 3a66806..e4fafdd 100644 --- a/src/io/fopen.c +++ b/src/io/fopen.c @@ -47,12 +47,12 @@ #include -#include "fopen.h" +#include "io/fopen.h" #ifdef FOPEN_STANDALONE CURLSH *io_share; #else -#include "consspaceobject.h" -#include "io.h" +#include "memory/consspaceobject.h" +#include "io/io.h" #include "utils.h" #endif diff --git a/src/io/io.c b/src/io/io.c index fe08a77..0125488 100644 --- a/src/io/io.c +++ b/src/io/io.c @@ -28,13 +28,13 @@ #include -#include "conspage.h" -#include "consspaceobject.h" +#include "memory/conspage.h" +#include "memory/consspaceobject.h" #include "debug.h" -#include "fopen.h" -#include "integer.h" -#include "intern.h" -#include "lispops.h" +#include "io/fopen.h" +#include "arith/integer.h" +#include "ops/intern.h" +#include "ops/lispops.h" #include "utils.h" /** @@ -56,8 +56,6 @@ wint_t ungotten = 0; * @return 0 on success; any other value means failure. */ int io_init( ) { - CURL *curl; - CURLcode res; int result = curl_global_init( CURL_GLOBAL_SSL ); io_share = curl_share_init( ); diff --git a/src/io/print.c b/src/io/print.c index 64d7b37..8f4b88e 100644 --- a/src/io/print.c +++ b/src/io/print.c @@ -17,15 +17,15 @@ #include #include -#include "conspage.h" -#include "consspaceobject.h" -#include "hashmap.h" -#include "integer.h" -#include "intern.h" -#include "stack.h" -#include "print.h" -#include "psse_time.h" -#include "vectorspace.h" +#include "memory/conspage.h" +#include "memory/consspaceobject.h" +#include "memory/hashmap.h" +#include "arith/integer.h" +#include "ops/intern.h" +#include "memory/stack.h" +#include "io/print.h" +#include "time/psse_time.h" +#include "memory/vectorspace.h" /** * print all the characters in the symbol or string indicated by `pointer` diff --git a/src/io/read.c b/src/io/read.c index 4425b77..45d1045 100644 --- a/src/io/read.c +++ b/src/io/read.c @@ -17,25 +17,29 @@ #include #include -#include "consspaceobject.h" +#include "memory/consspaceobject.h" #include "debug.h" -#include "dump.h" -#include "hashmap.h" -#include "integer.h" -#include "intern.h" -#include "io.h" -#include "lispops.h" -#include "peano.h" -#include "print.h" -#include "ratio.h" -#include "read.h" -#include "real.h" -#include "vectorspace.h" +#include "memory/dump.h" +#include "memory/hashmap.h" +#include "arith/integer.h" +#include "ops/intern.h" +#include "io/io.h" +#include "ops/lispops.h" +#include "arith/peano.h" +#include "io/print.h" +#include "arith/ratio.h" +#include "io/read.h" +#include "arith/real.h" +#include "memory/vectorspace.h" /* - * for the time being things which may be read are: strings numbers - either - * integer or real, but not yet including ratios or bignums lists Can't read - * atoms because I don't yet know what an atom is or how it's stored. + * for the time being things which may be read are: + * * strings + * * numbers - either integer, ratio or real + * * lists + * * maps + * * keywords + * * atoms */ struct cons_pointer read_number( struct stack_frame *frame, diff --git a/src/memory/conspage.c b/src/memory/conspage.c index f967c74..6cc4814 100644 --- a/src/memory/conspage.c +++ b/src/memory/conspage.c @@ -16,12 +16,12 @@ #include #include -#include "consspaceobject.h" -#include "conspage.h" +#include "memory/consspaceobject.h" +#include "memory/conspage.h" #include "debug.h" -#include "dump.h" -#include "stack.h" -#include "vectorspace.h" +#include "memory/dump.h" +#include "memory/stack.h" +#include "memory/vectorspace.h" /** * Flag indicating whether conspage initialisation has been done. @@ -267,4 +267,4 @@ void initialise_cons_pages( ) { void summarise_allocation() { fwprintf(stderr, L"Allocation summary: allocated %lld; deallocated %lld.\n", total_cells_allocated, total_cells_freed ); -} \ No newline at end of file +} diff --git a/src/memory/consspaceobject.c b/src/memory/consspaceobject.c index 0eef3d5..579e84b 100644 --- a/src/memory/consspaceobject.c +++ b/src/memory/consspaceobject.c @@ -19,13 +19,13 @@ #include #include "authorise.h" -#include "conspage.h" -#include "consspaceobject.h" +#include "memory/conspage.h" +#include "memory/consspaceobject.h" #include "debug.h" -#include "intern.h" -#include "print.h" -#include "stack.h" -#include "vectorspace.h" +#include "ops/intern.h" +#include "io/print.h" +#include "memory/stack.h" +#include "memory/vectorspace.h" /** * True if the value of the tag on the cell at this `pointer` is this `value`, diff --git a/src/memory/dump.c b/src/memory/dump.c index 81182a8..3148ac1 100644 --- a/src/memory/dump.c +++ b/src/memory/dump.c @@ -18,15 +18,15 @@ #include #include -#include "conspage.h" -#include "consspaceobject.h" +#include "memory/conspage.h" +#include "memory/consspaceobject.h" #include "debug.h" -#include "hashmap.h" -#include "intern.h" -#include "io.h" -#include "print.h" -#include "stack.h" -#include "vectorspace.h" +#include "memory/hashmap.h" +#include "ops/intern.h" +#include "io/io.h" +#include "io/print.h" +#include "memory/stack.h" +#include "memory/vectorspace.h" void dump_string_cell( URL_FILE * output, wchar_t *prefix, diff --git a/src/memory/hashmap.c b/src/memory/hashmap.c index d6909ba..a9bc336 100644 --- a/src/memory/hashmap.c +++ b/src/memory/hashmap.c @@ -11,7 +11,7 @@ #include "arith/peano.h" #include "authorise.h" #include "debug.h" -#include "intern.h" +#include "ops/intern.h" #include "io/print.h" #include "memory/conspage.h" #include "memory/consspaceobject.h" diff --git a/src/memory/stack.c b/src/memory/stack.c index 8b0e610..4b70ed1 100644 --- a/src/memory/stack.c +++ b/src/memory/stack.c @@ -17,14 +17,14 @@ #include -#include "consspaceobject.h" -#include "conspage.h" +#include "memory/consspaceobject.h" +#include "memory/conspage.h" #include "debug.h" -#include "dump.h" -#include "lispops.h" -#include "print.h" -#include "stack.h" -#include "vectorspace.h" +#include "memory/dump.h" +#include "ops/lispops.h" +#include "io/print.h" +#include "memory/stack.h" +#include "memory/vectorspace.h" /** * set a register in a stack frame. Alwaye use this to do so, diff --git a/src/memory/vectorspace.c b/src/memory/vectorspace.c index 0c1b159..4bbeb51 100644 --- a/src/memory/vectorspace.c +++ b/src/memory/vectorspace.c @@ -19,12 +19,12 @@ #include #include -#include "conspage.h" -#include "consspaceobject.h" +#include "memory/conspage.h" +#include "memory/consspaceobject.h" #include "debug.h" -#include "hashmap.h" -#include "stack.h" -#include "vectorspace.h" +#include "memory/hashmap.h" +#include "memory/stack.h" +#include "memory/vectorspace.h" /** diff --git a/src/ops/intern.c b/src/ops/intern.c index 05d5822..cd80612 100644 --- a/src/ops/intern.c +++ b/src/ops/intern.c @@ -19,12 +19,12 @@ #include -#include "conspage.h" -#include "consspaceobject.h" +#include "memory/conspage.h" +#include "memory/consspaceobject.h" #include "debug.h" -#include "equal.h" -#include "hashmap.h" -#include "lispops.h" +#include "ops/equal.h" +#include "memory/hashmap.h" +#include "ops/lispops.h" // #include "print.h" /** diff --git a/src/ops/lispops.c b/src/ops/lispops.c index fa3c68d..4ff14a1 100644 --- a/src/ops/lispops.c +++ b/src/ops/lispops.c @@ -24,19 +24,19 @@ #include #include -#include "consspaceobject.h" -#include "conspage.h" +#include "memory/consspaceobject.h" +#include "memory/conspage.h" #include "debug.h" -#include "dump.h" -#include "equal.h" -#include "integer.h" -#include "intern.h" -#include "io.h" -#include "lispops.h" -#include "print.h" -#include "read.h" -#include "stack.h" -#include "vectorspace.h" +#include "memory/dump.h" +#include "ops/equal.h" +#include "arith/integer.h" +#include "ops/intern.h" +#include "io/io.h" +#include "ops/lispops.h" +#include "io/print.h" +#include "io/read.h" +#include "memory/stack.h" +#include "memory/vectorspace.h" /* * also to create in this section: diff --git a/src/ops/meta.c b/src/ops/meta.c index a27d2af..f00824f 100644 --- a/src/ops/meta.c +++ b/src/ops/meta.c @@ -7,7 +7,7 @@ * Licensed under GPL version 2.0, or, at your option, any later version. */ -#include "conspage.h" +#include "memory/conspage.h" #include "debug.h" /** diff --git a/src/repl.c b/src/repl.c index 39bbde6..bef08b1 100644 --- a/src/repl.c +++ b/src/repl.c @@ -11,11 +11,11 @@ #include #include -#include "consspaceobject.h" +#include "memory/consspaceobject.h" #include "debug.h" -#include "intern.h" -#include "lispops.h" -#include "stack.h" +#include "ops/intern.h" +#include "ops/lispops.h" +#include "memory/stack.h" /** diff --git a/src/time/psse_time.c b/src/time/psse_time.c index 1f24b0e..06c1b58 100644 --- a/src/time/psse_time.c +++ b/src/time/psse_time.c @@ -16,10 +16,10 @@ #include #include -#include "conspage.h" -#include "consspaceobject.h" -#include "integer.h" -#include "psse_time.h" +#include "memory/conspage.h" +#include "memory/consspaceobject.h" +#include "arith/integer.h" +#include "time/psse_time.h" #define _GNU_SOURCE #define seconds_per_year 31557600L @@ -63,7 +63,6 @@ struct cons_pointer make_time( struct cons_pointer integer_or_nil ) { if ( integerp( integer_or_nil ) ) { cell->payload.time.value = pointer2cell( integer_or_nil ).payload.integer.value; - // \todo: if integer is a bignum, deal with it. } else { cell->payload.time.value = unix_time_to_lisp_time( time( NULL ) ); } From 40e35022475915608e630deb15402772499b4819 Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Sun, 12 Sep 2021 15:06:05 +0100 Subject: [PATCH 24/28] Standardised format (with `make format`) --- src/init.c | 6 +- src/io/io.c | 4 +- src/memory/conspage.c | 10 +-- src/memory/conspage.h | 2 +- src/memory/dump.c | 8 +-- src/memory/hashmap.c | 4 +- src/ops/lispops.c | 144 ++++++++++++++++++++++-------------------- src/ops/lispops.h | 6 +- 8 files changed, 97 insertions(+), 87 deletions(-) diff --git a/src/init.c b/src/init.c index 12187fd..ff8c190 100644 --- a/src/init.c +++ b/src/init.c @@ -238,7 +238,7 @@ int main( int argc, char *argv[] ) { bind_function( L"hashmap", lisp_make_hashmap ); bind_function( L"inspect", &lisp_inspect ); bind_function( L"keys", &lisp_keys ); - bind_function( L"list", &lisp_list); + bind_function( L"list", &lisp_list ); bind_function( L"mapcar", &lisp_mapcar ); bind_function( L"meta", &lisp_metadata ); bind_function( L"metadata", &lisp_metadata ); @@ -272,7 +272,7 @@ int main( int argc, char *argv[] ) { bind_special( L"cond", &lisp_cond ); bind_special( L"lambda", &lisp_lambda ); bind_special( L"\u03bb", &lisp_lambda ); // λ - bind_special(L"let", &lisp_let); + bind_special( L"let", &lisp_let ); bind_special( L"nlambda", &lisp_nlambda ); bind_special( L"n\u03bb", &lisp_nlambda ); bind_special( L"progn", &lisp_progn ); @@ -290,7 +290,7 @@ int main( int argc, char *argv[] ) { dump_pages( file_to_url_file( stdout ) ); } - summarise_allocation(); + summarise_allocation( ); curl_global_cleanup( ); return ( 0 ); } diff --git a/src/io/io.c b/src/io/io.c index 0125488..d01f788 100644 --- a/src/io/io.c +++ b/src/io/io.c @@ -502,8 +502,8 @@ lisp_read_char( struct stack_frame *frame, struct cons_pointer frame_pointer, if ( readp( frame->arg[0] ) ) { result = make_string( url_fgetwc - ( pointer2cell( frame->arg[0] ).payload. - stream.stream ), NIL ); + ( pointer2cell( frame->arg[0] ).payload.stream. + stream ), NIL ); } return result; diff --git a/src/memory/conspage.c b/src/memory/conspage.c index 6cc4814..f8802cc 100644 --- a/src/memory/conspage.c +++ b/src/memory/conspage.c @@ -193,7 +193,7 @@ void free_cell( struct cons_pointer pointer ) { cell->payload.free.car = NIL; cell->payload.free.cdr = freelist; freelist = pointer; - total_cells_freed ++; + total_cells_freed++; } else { debug_printf( DEBUG_ALLOC, L"ERROR: Attempt to free cell with %d dangling references at page %d, offset %d\n", @@ -235,7 +235,7 @@ struct cons_pointer allocate_cell( uint32_t tag ) { cell->payload.cons.car = NIL; cell->payload.cons.cdr = NIL; - total_cells_allocated ++; + total_cells_allocated++; debug_printf( DEBUG_ALLOC, L"Allocated cell of type '%4.4s' at %d, %d \n", tag, @@ -265,6 +265,8 @@ void initialise_cons_pages( ) { } } -void summarise_allocation() { - fwprintf(stderr, L"Allocation summary: allocated %lld; deallocated %lld.\n", total_cells_allocated, total_cells_freed ); +void summarise_allocation( ) { + fwprintf( stderr, + L"Allocation summary: allocated %lld; deallocated %lld.\n", + total_cells_allocated, total_cells_freed ); } diff --git a/src/memory/conspage.h b/src/memory/conspage.h index 18eda3b..589f6bf 100644 --- a/src/memory/conspage.h +++ b/src/memory/conspage.h @@ -61,6 +61,6 @@ void initialise_cons_pages( ); void dump_pages( URL_FILE * output ); -void summarise_allocation(); +void summarise_allocation( ); #endif diff --git a/src/memory/dump.c b/src/memory/dump.c index 3148ac1..2bc5bb0 100644 --- a/src/memory/dump.c +++ b/src/memory/dump.c @@ -114,10 +114,10 @@ void dump_object( URL_FILE * output, struct cons_pointer pointer ) { case RATIOTV: url_fwprintf( output, L"\t\tRational cell: value %ld/%ld, count %u\n", - pointer2cell( cell.payload.ratio.dividend ). - payload.integer.value, - pointer2cell( cell.payload.ratio.divisor ). - payload.integer.value, cell.count ); + pointer2cell( cell.payload.ratio.dividend ).payload. + integer.value, + pointer2cell( cell.payload.ratio.divisor ).payload. + integer.value, cell.count ); break; case READTV: url_fputws( L"\t\tInput stream; metadata: ", output ); diff --git a/src/memory/hashmap.c b/src/memory/hashmap.c index a9bc336..5e1db0a 100644 --- a/src/memory/hashmap.c +++ b/src/memory/hashmap.c @@ -180,8 +180,8 @@ struct cons_pointer lisp_make_hashmap( struct stack_frame *frame, map->payload.hashmap.buckets[bucket_no] = inc_ref( make_cons( make_cons( key, val ), - map->payload. - hashmap.buckets[bucket_no] ) ); + map->payload.hashmap. + buckets[bucket_no] ) ); } } } diff --git a/src/ops/lispops.c b/src/ops/lispops.c index 4ff14a1..c4ca4f3 100644 --- a/src/ops/lispops.c +++ b/src/ops/lispops.c @@ -61,7 +61,7 @@ struct cons_pointer eval_form( struct stack_frame *parent, struct cons_pointer env ) { debug_print( L"eval_form: ", DEBUG_EVAL ); debug_print_object( form, DEBUG_EVAL ); - debug_println(DEBUG_EVAL); + debug_println( DEBUG_EVAL ); struct cons_pointer result = NIL; struct cons_pointer next_pointer = make_empty_frame( parent_pointer ); @@ -82,7 +82,7 @@ struct cons_pointer eval_form( struct stack_frame *parent, debug_print( L"eval_form returning: ", DEBUG_EVAL ); debug_print_object( result, DEBUG_EVAL ); - debug_println(DEBUG_EVAL); + debug_println( DEBUG_EVAL ); return result; } @@ -416,9 +416,10 @@ c_apply( struct stack_frame *frame, struct cons_pointer frame_pointer, result = next_pointer; } else { result = - ( *fn_cell.payload.special. - executable ) ( get_stack_frame( next_pointer ), - next_pointer, env ); + ( *fn_cell.payload. + special.executable ) ( get_stack_frame + ( next_pointer ), + next_pointer, env ); debug_print( L"Special form returning: ", DEBUG_EVAL ); debug_print_object( result, DEBUG_EVAL ); debug_println( DEBUG_EVAL ); @@ -594,10 +595,10 @@ lisp_set( struct stack_frame *frame, struct cons_pointer frame_pointer, } else { result = throw_exception( make_cons - ( c_string_to_lisp_string - ( L"The first argument to `set` is not a symbol: " ), - make_cons( frame->arg[0], NIL ) ), - frame_pointer ); + ( c_string_to_lisp_string + ( L"The first argument to `set` is not a symbol: " ), + make_cons( frame->arg[0], NIL ) ), + frame_pointer ); } return result; @@ -633,10 +634,10 @@ lisp_set_shriek( struct stack_frame *frame, struct cons_pointer frame_pointer, } else { result = throw_exception( make_cons - ( c_string_to_lisp_string - ( L"The first argument to `set!` is not a symbol: " ), - make_cons( frame->arg[0], NIL ) ), - frame_pointer ); + ( c_string_to_lisp_string + ( L"The first argument to `set!` is not a symbol: " ), + make_cons( frame->arg[0], NIL ) ), + frame_pointer ); } return result; @@ -1213,7 +1214,8 @@ lisp_exception( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ) { struct cons_pointer message = frame->arg[0]; return exceptionp( message ) ? message : throw_exception( message, - frame->previous ); + frame-> + previous ); } /** @@ -1380,13 +1382,14 @@ struct cons_pointer c_append( struct cons_pointer l1, struct cons_pointer l2 ) { if ( pointer2cell( l1 ).tag.value == pointer2cell( l2 ).tag.value ) { if ( nilp( c_cdr( l1 ) ) ) { return - make_string_like_thing( ( pointer2cell( l1 ).payload. - string.character ), l2, + make_string_like_thing( ( pointer2cell( l1 ). + payload.string.character ), + l2, pointer2cell( l1 ).tag.value ); } else { return - make_string_like_thing( ( pointer2cell( l1 ).payload. - string.character ), + make_string_like_thing( ( pointer2cell( l1 ). + payload.string.character ), c_append( c_cdr( l1 ), l2 ), pointer2cell( l1 ).tag.value ); } @@ -1408,13 +1411,13 @@ struct cons_pointer c_append( struct cons_pointer l1, struct cons_pointer l2 ) { struct cons_pointer lisp_append( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ) { - struct cons_pointer result = fetch_arg(frame, (frame->args - 1)); + struct cons_pointer result = fetch_arg( frame, ( frame->args - 1 ) ); - for (int a = frame->args - 2; a >= 0; a--) { - result = c_append(fetch_arg(frame, a), result); - } + for ( int a = frame->args - 2; a >= 0; a-- ) { + result = c_append( fetch_arg( frame, a ), result ); + } - return result; + return result; } struct cons_pointer lisp_mapcar( struct stack_frame *frame, @@ -1426,34 +1429,35 @@ struct cons_pointer lisp_mapcar( struct stack_frame *frame, int i = 0; for ( struct cons_pointer c = frame->arg[1]; truep( c ); c = c_cdr( c ) ) { - struct cons_pointer expr = make_cons(frame->arg[0], make_cons(c_car(c), NIL)); - inc_ref(expr); + struct cons_pointer expr = + make_cons( frame->arg[0], make_cons( c_car( c ), NIL ) ); + inc_ref( expr ); - debug_printf(DEBUG_EVAL, L"Mapcar %d, evaluating ", i); - debug_print_object( expr, DEBUG_EVAL); - debug_println(DEBUG_EVAL); + debug_printf( DEBUG_EVAL, L"Mapcar %d, evaluating ", i ); + debug_print_object( expr, DEBUG_EVAL ); + debug_println( DEBUG_EVAL ); - struct cons_pointer r = eval_form(frame, frame_pointer, expr, env); + struct cons_pointer r = eval_form( frame, frame_pointer, expr, env ); if ( exceptionp( r ) ) { result = r; - inc_ref( expr ); // to protect exception from the later dec_ref + inc_ref( expr ); // to protect exception from the later dec_ref break; } else { result = make_cons( r, result ); } - debug_printf(DEBUG_EVAL, L"Mapcar %d, result is ", i++); - debug_print_object( result, DEBUG_EVAL); - debug_println(DEBUG_EVAL); + debug_printf( DEBUG_EVAL, L"Mapcar %d, result is ", i++ ); + debug_print_object( result, DEBUG_EVAL ); + debug_println( DEBUG_EVAL ); dec_ref( expr ); } - result = consp(result) ? c_reverse( result ) : result; + result = consp( result ) ? c_reverse( result ) : result; debug_print( L"Mapcar returning: ", DEBUG_EVAL ); debug_print_object( result, DEBUG_EVAL ); - debug_println(DEBUG_EVAL); + debug_println( DEBUG_EVAL ); return result; } @@ -1461,14 +1465,14 @@ struct cons_pointer lisp_mapcar( struct stack_frame *frame, struct cons_pointer lisp_list( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ) { - struct cons_pointer result = frame->more; + struct cons_pointer result = frame->more; - for ( int a = nilp(result) ? frame->args - 1: args_in_frame - 1; - a >= 0; a-- ) { - result = make_cons(fetch_arg(frame, a), result); - } + for ( int a = nilp( result ) ? frame->args - 1 : args_in_frame - 1; + a >= 0; a-- ) { + result = make_cons( fetch_arg( frame, a ), result ); + } - return result; + return result; } /** @@ -1477,38 +1481,42 @@ struct cons_pointer lisp_list( struct stack_frame *frame, * This is `let*` in Common Lisp parlance; `let` in Clojure parlance. */ struct cons_pointer lisp_let( struct stack_frame *frame, - struct cons_pointer frame_pointer, - struct cons_pointer env) { - struct cons_pointer bindings = env; - struct cons_pointer result = NIL; + struct cons_pointer frame_pointer, + struct cons_pointer env ) { + struct cons_pointer bindings = env; + struct cons_pointer result = NIL; - for (struct cons_pointer cursor = frame->arg[0]; - truep(cursor); - cursor = c_cdr(cursor)) { - struct cons_pointer pair = c_car(cursor); - struct cons_pointer symbol = c_car(pair); + for ( struct cons_pointer cursor = frame->arg[0]; + truep( cursor ); cursor = c_cdr( cursor ) ) { + struct cons_pointer pair = c_car( cursor ); + struct cons_pointer symbol = c_car( pair ); - if (symbolp(symbol)) { - bindings = make_cons( - make_cons(symbol, eval_form(frame, frame_pointer, c_cdr(pair), bindings)), - bindings); - - } else { - result = throw_exception( - c_string_to_lisp_string(L"Let: cannot bind, not a symbol"), - frame_pointer); - break; - } - } + if ( symbolp( symbol ) ) { + bindings = + make_cons( make_cons + ( symbol, + eval_form( frame, frame_pointer, c_cdr( pair ), + bindings ) ), bindings ); - /* i.e., no exception yet */ - for (int form = 1; !exceptionp(result) && form < frame->args; form++) { - result = eval_form(frame, frame_pointer, fetch_arg(frame, form), bindings); - } + } else { + result = + throw_exception( c_string_to_lisp_string + ( L"Let: cannot bind, not a symbol" ), + frame_pointer ); + break; + } + } - return result; + /* i.e., no exception yet */ + for ( int form = 1; !exceptionp( result ) && form < frame->args; form++ ) { + result = + eval_form( frame, frame_pointer, fetch_arg( frame, form ), + bindings ); + } - } + return result; + +} // /** // * Function; print the internal representation of the object indicated by `frame->arg[0]` to the diff --git a/src/ops/lispops.h b/src/ops/lispops.h index 3d1c4f7..ba1e999 100644 --- a/src/ops/lispops.h +++ b/src/ops/lispops.h @@ -212,11 +212,11 @@ struct cons_pointer lisp_mapcar( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ); - struct cons_pointer lisp_list( struct stack_frame *frame, +struct cons_pointer lisp_list( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ); struct cons_pointer lisp_let( struct stack_frame *frame, - struct cons_pointer frame_pointer, - struct cons_pointer env); + struct cons_pointer frame_pointer, + struct cons_pointer env ); #endif From 462c0c69b4e0513c34c27d75fa4a291a04ae50d9 Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Sun, 12 Sep 2021 15:28:27 +0100 Subject: [PATCH 25/28] Fixed bug that reading map literal didn't evaluate values. --- src/io/read.c | 33 ++++++++++++++-------- src/io/read.h | 4 ++- src/ops/lispops.c | 70 +++++++++++++++++++++++++++++++---------------- 3 files changed, 71 insertions(+), 36 deletions(-) diff --git a/src/io/read.c b/src/io/read.c index 45d1045..df0735b 100644 --- a/src/io/read.c +++ b/src/io/read.c @@ -48,9 +48,11 @@ struct cons_pointer read_number( struct stack_frame *frame, bool seen_period ); struct cons_pointer read_list( struct stack_frame *frame, struct cons_pointer frame_pointer, + struct cons_pointer env, URL_FILE * input, wint_t initial ); struct cons_pointer read_map( struct stack_frame *frame, struct cons_pointer frame_pointer, + struct cons_pointer env, URL_FILE * input, wint_t initial ); struct cons_pointer read_string( URL_FILE * input, wint_t initial ); struct cons_pointer read_symbol_or_key( URL_FILE * input, uint32_t tag, @@ -142,6 +144,7 @@ struct cons_pointer read_path( URL_FILE * input, wint_t initial, */ struct cons_pointer read_continuation( struct stack_frame *frame, struct cons_pointer frame_pointer, + struct cons_pointer env, URL_FILE * input, wint_t initial ) { debug_print( L"entering read_continuation\n", DEBUG_IO ); struct cons_pointer result = NIL; @@ -171,16 +174,16 @@ struct cons_pointer read_continuation( struct stack_frame *frame, case '\'': result = c_quote( read_continuation - ( frame, frame_pointer, input, + ( frame, frame_pointer, env, input, url_fgetwc( input ) ) ); break; case '(': result = - read_list( frame, frame_pointer, input, + read_list( frame, frame_pointer, env, input, url_fgetwc( input ) ); break; case '{': - result = read_map( frame, frame_pointer, input, + result = read_map( frame, frame_pointer, env, input, url_fgetwc( input ) ); break; case '"': @@ -210,8 +213,8 @@ struct cons_pointer read_continuation( struct stack_frame *frame, /* dotted pair. \todo this isn't right, we * really need to backtrack up a level. */ result = - read_continuation( frame, frame_pointer, input, - url_fgetwc( input ) ); + read_continuation( frame, frame_pointer, env, + input, url_fgetwc( input ) ); debug_print ( L"read_continuation: dotted pair; read cdr ", DEBUG_IO ); @@ -383,6 +386,7 @@ struct cons_pointer read_number( struct stack_frame *frame, */ struct cons_pointer read_list( struct stack_frame *frame, struct cons_pointer frame_pointer, + struct cons_pointer env, URL_FILE * input, wint_t initial ) { struct cons_pointer result = NIL; wint_t c; @@ -391,7 +395,7 @@ struct cons_pointer read_list( struct stack_frame *frame, debug_printf( DEBUG_IO, L"read_list starting '%C' (%d)\n", initial, initial ); struct cons_pointer car = - read_continuation( frame, frame_pointer, input, + read_continuation( frame, frame_pointer, env, input, initial ); /* skip whitespace */ @@ -406,10 +410,12 @@ struct cons_pointer read_list( struct stack_frame *frame, make_cons( car, c_car( read_list( frame, frame_pointer, + env, input, url_fgetwc( input ) ) ) ); } else { result = - make_cons( car, read_list( frame, frame_pointer, input, c ) ); + make_cons( car, + read_list( frame, frame_pointer, env, input, c ) ); } } else { debug_print( L"End of list detected\n", DEBUG_IO ); @@ -420,6 +426,7 @@ struct cons_pointer read_list( struct stack_frame *frame, struct cons_pointer read_map( struct stack_frame *frame, struct cons_pointer frame_pointer, + struct cons_pointer env, URL_FILE * input, wint_t initial ) { // set write ACL to true whilst creating to prevent GC churn struct cons_pointer result = @@ -428,21 +435,23 @@ struct cons_pointer read_map( struct stack_frame *frame, while ( c != L'}' ) { struct cons_pointer key = - read_continuation( frame, frame_pointer, input, c ); + read_continuation( frame, frame_pointer, env, input, c ); /* skip whitespace */ for ( c = url_fgetwc( input ); iswblank( c ) || iswcntrl( c ); c = url_fgetwc( input ) ); struct cons_pointer value = - read_continuation( frame, frame_pointer, input, c ); + read_continuation( frame, frame_pointer, env, input, c ); /* skip commaa and whitespace at this point. */ for ( c = url_fgetwc( input ); c == L',' || iswblank( c ) || iswcntrl( c ); c = url_fgetwc( input ) ); - result = hashmap_put( result, key, value ); + result = + hashmap_put( result, key, + eval_form( frame, frame_pointer, value, env ) ); } // default write ACL for maps should be NIL. @@ -536,7 +545,7 @@ struct cons_pointer read_symbol_or_key( URL_FILE * input, uint32_t tag, struct cons_pointer read( struct stack_frame *frame, struct cons_pointer frame_pointer, - URL_FILE * input ) { - return read_continuation( frame, frame_pointer, input, + struct cons_pointer env, URL_FILE * input ) { + return read_continuation( frame, frame_pointer, env, input, url_fgetwc( input ) ); } diff --git a/src/io/read.h b/src/io/read.h index 64f36b0..031bb4f 100644 --- a/src/io/read.h +++ b/src/io/read.h @@ -11,11 +11,13 @@ #ifndef __read_h #define __read_h +#include "memory/consspaceobject.h" + /** * read the next object on this input stream and return a cons_pointer to it. */ struct cons_pointer read( struct stack_frame *frame, struct cons_pointer frame_pointer, - URL_FILE * input ); + struct cons_pointer env, URL_FILE * input ); #endif diff --git a/src/ops/lispops.c b/src/ops/lispops.c index c4ca4f3..436f4df 100644 --- a/src/ops/lispops.c +++ b/src/ops/lispops.c @@ -63,21 +63,45 @@ struct cons_pointer eval_form( struct stack_frame *parent, debug_print_object( form, DEBUG_EVAL ); debug_println( DEBUG_EVAL ); - struct cons_pointer result = NIL; - struct cons_pointer next_pointer = make_empty_frame( parent_pointer ); - inc_ref( next_pointer ); + struct cons_pointer result = form; + switch ( pointer2cell( form ).tag.value ) { + /* things which evaluate to themselves */ + case EXCEPTIONTV: + case FREETV: // shouldn't happen, but anyway... + // FUNCTIONTV, LAMBDATV, NLAMBDATV, SPECIALTV ? + case INTEGERTV: + case KEYTV: + case LOOPTV: // don't think this should happen... + case NILTV: + case RATIOTV: + case REALTV: + case READTV: + case STRINGTV: + case TIMETV: + case TRUETV: + // case VECTORPOINTTV: ? + case WRITETV: + break; + default: + { + struct cons_pointer next_pointer = + make_empty_frame( parent_pointer ); + inc_ref( next_pointer ); - struct stack_frame *next = get_stack_frame( next_pointer ); - set_reg( next, 0, form ); - next->args = 1; + struct stack_frame *next = get_stack_frame( next_pointer ); + set_reg( next, 0, form ); + next->args = 1; - result = lisp_eval( next, next_pointer, env ); + result = lisp_eval( next, next_pointer, env ); - if ( !exceptionp( result ) ) { - /* if we're returning an exception, we should NOT free the - * stack frame. Corollary is, when we free an exception, we - * should free all the frames it's holding on to. */ - dec_ref( next_pointer ); + if ( !exceptionp( result ) ) { + /* if we're returning an exception, we should NOT free the + * stack frame. Corollary is, when we free an exception, we + * should free all the frames it's holding on to. */ + dec_ref( next_pointer ); + } + } + break; } debug_print( L"eval_form returning: ", DEBUG_EVAL ); @@ -113,16 +137,16 @@ struct cons_pointer eval_forms( struct stack_frame *frame, } /** - * OK, the idea here (and I know this is less than perfect) is that the basic `try` - * function in PSSE takes two arguments, the first, `body`, being a list of forms, - * and the second, `catch`, being a catch handler (which is also a list of forms). - * Forms from `body` are evaluated in turn until one returns an exception object, + * OK, the idea here (and I know this is less than perfect) is that the basic `try` + * function in PSSE takes two arguments, the first, `body`, being a list of forms, + * and the second, `catch`, being a catch handler (which is also a list of forms). + * Forms from `body` are evaluated in turn until one returns an exception object, * or until the list is exhausted. If the list was exhausted, then the value of - * evaluating the last form in `body` is returned. If an exception was encountered, - * then each of the forms in `catch` is evaluated and the value of the last of + * evaluating the last form in `body` is returned. If an exception was encountered, + * then each of the forms in `catch` is evaluated and the value of the last of * those is returned. - * - * This is experimental. It almost certainly WILL change. + * + * This is experimental. It almost certainly WILL change. */ struct cons_pointer lisp_try( struct stack_frame *frame, struct cons_pointer frame_pointer, @@ -891,7 +915,7 @@ lisp_read( struct stack_frame *frame, struct cons_pointer frame_pointer, input = file_to_url_file( stdin ); } - struct cons_pointer result = read( frame, frame_pointer, input ); + struct cons_pointer result = read( frame, frame_pointer, env, input ); debug_print( L"lisp_read returning\n", DEBUG_IO ); debug_dump_object( result, DEBUG_IO ); @@ -1406,7 +1430,7 @@ struct cons_pointer c_append( struct cons_pointer l1, struct cons_pointer l2 ) { } /** - * should really be overwritten with a version in Lisp, since this is much easier to write in Lisp + * should really be overwritten with a version in Lisp, since this is much easier to write in Lisp */ struct cons_pointer lisp_append( struct stack_frame *frame, struct cons_pointer frame_pointer, @@ -1476,7 +1500,7 @@ struct cons_pointer lisp_list( struct stack_frame *frame, } /** - * Special form: evaluate a series of forms in an environment in which + * Special form: evaluate a series of forms in an environment in which * these bindings are bound. * This is `let*` in Common Lisp parlance; `let` in Clojure parlance. */ From a8315d649f40d8249f10992924fd755593d700e7 Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Sun, 12 Sep 2021 16:20:13 +0100 Subject: [PATCH 26/28] Made try/catch actually work --- src/init.c | 1 + src/ops/lispops.c | 23 ++++++++++------------- src/ops/lispops.h | 4 ++++ unit-tests/try.sh | 45 +++++++++++++++++++++++++++++++++++++++++++++ 4 files changed, 60 insertions(+), 13 deletions(-) create mode 100755 unit-tests/try.sh diff --git a/src/init.c b/src/init.c index ff8c190..dee2b7c 100644 --- a/src/init.c +++ b/src/init.c @@ -278,6 +278,7 @@ int main( int argc, char *argv[] ) { bind_special( L"progn", &lisp_progn ); bind_special( L"quote", &lisp_quote ); bind_special( L"set!", &lisp_set_shriek ); + bind_special( L"try", &lisp_try ); debug_print( L"Initialised oblist\n", DEBUG_BOOTSTRAP ); debug_dump_object( oblist, DEBUG_BOOTSTRAP ); diff --git a/src/ops/lispops.c b/src/ops/lispops.c index 436f4df..917f7b5 100644 --- a/src/ops/lispops.c +++ b/src/ops/lispops.c @@ -138,7 +138,7 @@ struct cons_pointer eval_forms( struct stack_frame *frame, /** * OK, the idea here (and I know this is less than perfect) is that the basic `try` - * function in PSSE takes two arguments, the first, `body`, being a list of forms, + * special form in PSSE takes two arguments, the first, `body`, being a list of forms, * and the second, `catch`, being a catch handler (which is also a list of forms). * Forms from `body` are evaluated in turn until one returns an exception object, * or until the list is exhausted. If the list was exhausted, then the value of @@ -158,7 +158,7 @@ struct cons_pointer lisp_try( struct stack_frame *frame, // TODO: need to put the exception into the environment! result = c_progn( frame, frame_pointer, frame->arg[1], make_cons( make_cons - ( c_string_to_lisp_keyword + ( c_string_to_lisp_symbol ( L"*exception*" ), result ), env ) ); } @@ -440,10 +440,9 @@ c_apply( struct stack_frame *frame, struct cons_pointer frame_pointer, result = next_pointer; } else { result = - ( *fn_cell.payload. - special.executable ) ( get_stack_frame - ( next_pointer ), - next_pointer, env ); + ( *fn_cell.payload.special. + executable ) ( get_stack_frame( next_pointer ), + next_pointer, env ); debug_print( L"Special form returning: ", DEBUG_EVAL ); debug_print_object( result, DEBUG_EVAL ); debug_println( DEBUG_EVAL ); @@ -1238,8 +1237,7 @@ lisp_exception( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ) { struct cons_pointer message = frame->arg[0]; return exceptionp( message ) ? message : throw_exception( message, - frame-> - previous ); + frame->previous ); } /** @@ -1406,14 +1404,13 @@ struct cons_pointer c_append( struct cons_pointer l1, struct cons_pointer l2 ) { if ( pointer2cell( l1 ).tag.value == pointer2cell( l2 ).tag.value ) { if ( nilp( c_cdr( l1 ) ) ) { return - make_string_like_thing( ( pointer2cell( l1 ). - payload.string.character ), - l2, + make_string_like_thing( ( pointer2cell( l1 ).payload. + string.character ), l2, pointer2cell( l1 ).tag.value ); } else { return - make_string_like_thing( ( pointer2cell( l1 ). - payload.string.character ), + make_string_like_thing( ( pointer2cell( l1 ).payload. + string.character ), c_append( c_cdr( l1 ), l2 ), pointer2cell( l1 ).tag.value ); } diff --git a/src/ops/lispops.h b/src/ops/lispops.h index ba1e999..da1f27e 100644 --- a/src/ops/lispops.h +++ b/src/ops/lispops.h @@ -219,4 +219,8 @@ struct cons_pointer lisp_list( struct stack_frame *frame, struct cons_pointer lisp_let( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ); + +struct cons_pointer lisp_try( struct stack_frame *frame, + struct cons_pointer frame_pointer, + struct cons_pointer env ); #endif diff --git a/unit-tests/try.sh b/unit-tests/try.sh new file mode 100755 index 0000000..a6d529c --- /dev/null +++ b/unit-tests/try.sh @@ -0,0 +1,45 @@ +#!/bin/bash + +expected=':foo' +actual=`echo "(try ((+ 2 (/ 1 'a))) (:foo))" | target/psse | tail -1` + +if [ "${expected}" = "${actual}" ] +then + echo "OK" +else + echo "Fail: expected '${expected}', got '${actual}'" + exit 1 +fi + +expected='4' +actual=`echo "(try ((+ 2 (/ 1 'a))) ((+ 2 2)))" | target/psse | tail -1` + +if [ "${expected}" = "${actual}" ] +then + echo "OK" +else + echo "Fail: expected '${expected}', got '${actual}'" + exit 1 +fi + +expected='8' +actual=`echo "(try (:body (+ 2 (/ 1 'a))) (:catch (* 2 2 2)))" | target/psse | tail -1` + +if [ "${expected}" = "${actual}" ] +then + echo "OK" +else + echo "Fail: expected '${expected}', got '${actual}'" + exit 1 +fi + +expected='' +actual=`echo "(try (:body (+ 2 (/ 1 'a))) (:catch *exception*))" | target/psse | tail -1` + +if [ "${expected}" = "${actual}" ] +then + echo "OK" +else + echo "Fail: expected '${expected}', got '${actual}'" + exit 1 +fi From 86961577a6d8f86ee395cf5d21f4825c1d1bbb9d Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Sun, 12 Sep 2021 18:43:07 +0100 Subject: [PATCH 27/28] Mostly more documentation --- README.md | 114 ++++++++++++++++++++++++++++++++++++++++++++-- src/init.c | 5 +- src/ops/lispops.c | 27 +++++++++-- 3 files changed, 134 insertions(+), 12 deletions(-) diff --git a/README.md b/README.md index 408818c..145b870 100644 --- a/README.md +++ b/README.md @@ -12,9 +12,11 @@ Has working Lisp interpreter, more or less complete, with functions and symbols At the time of writing, big number arithmetic is completely failing. It has worked in the past, but it doesn't now. +There are ludicrous memory leaks. Essentially the garbage collection strategy isn't yet really working. However, if we are to implement the hypercube architecture in future, a mark and sweep garbage collector will not work, so it's important to get the reference counter working properly. + #### Unknown bugs -It's pretty likely that there are memory leaks. +There are certainly MANY unknown bugs. Please report those you find. #### Not yet implemented @@ -127,7 +129,7 @@ Divides the number *n1* by the number *n2*. If *n1* and *n2* are both integers, Returns true (`t`) if *o1* and *o2* are identically the same object, else `nil`. -#### (equal *o1* *o2*) +#### (equal *o1* *o2*), (= *o1* *o2*) Returns true (`t`) if *o1* and *o2* are structurally identical to one another, else `nil`. @@ -183,7 +185,111 @@ Returns a sequence of all the names bound in the root of the naming system. Opens a stream to the specified *url*. If a second argument is present and is non-`nil`, the stream is opened for reading; otherwise, it's opened for writing. -### Types +#### (print *o* [*stream*]) + +Prints the print-name of object *o* to the output stream which is the value of *stream*, or to the value of \*out\* in the current environment if no *stream* is provided. + +#### (put! *map* *key* *value*) + +Puts *value* as the value of *key* in hashmap *map*, destructively modifying it, and returns the map. Note that in future this will work only if the current user has write access to the specified map. + +#### (put-all! *map* *assoc*) + +Puts each (+key* . *value*) pair from the association list *assoc* into this *map*, destructively modifying it, and returns the map. Note that in future this will work only if the current user has write access to the specified map. + +#### (read [*stream*]) + +Reads a single Lisp form from the input stream which is the value of *stream*, or from the value of \*in\* in the current environment if no *stream* is provided. + +#### (read-char [*stream*]) + +Return the next character from the stream indicated by *stream*, or from the value of \*in\* in the current environment if no *stream* is provided; further arguments are ignored. + +#### (repl [*prompt* *input* *output*)) + +Initiate a new Read/Eval/Print loop with this *prompt*, reading from this *input* stream and writing to this *output* stream. All arguments are optional and default sensibly if omitted. TODO: doesn't actually work yet. + +#### (reverse *seq*) + +Return a new sequence of the same type as *seq*, containing the same elements but in the reverse order. + +#### (slurp *in*) + +Reads all available characters on input stream *in* into a string, and returns the string. + +#### (source *fn*) + +Should return the source code of the function or special form *fn*, but as we don't yet +have a compiler, doesn't. + +#### (subtract *n1* *n2*), (- *n1* *n2*) + +Subtracts the numeric value *n2* from the numeric value *n1*, and returns the difference. + +#### (throw *message*) + +Throws an exception, with the payload *message*. While *message* is at present most usefully a string, it doesn't have to be. Returns the exception, but as exceptions are handled specially by `eval`, it is returned to the catch block of the nearest `try` expression on the stack. + +#### (time [*milliseconds-since-epoch*]) + +Returns a time object whose value is the specified number of *milliseconds-since-epoch*, where the Post Scarcity Software Environment epoch is 14 billion years prior to the UN*X epoch. If *milliseconds-since-epoch* is not specified, returns a time object representing the UTC time when the function was executed. + +#### (type *o*) + +Returns a string representing the type -- actually the tag value -- of the object *o*. + +### Special forms + +#### (cond (test value) ...) + +Evaluates a series of *(test value)* clauses in turn until a test returns non-nil, when the corresponding value is returned and further tests are not evaluated. This is the same syntax as Common Lisp's `cond` implementation, and different from Clojure's. + +It's conventional in Lisp to have a final clause in a `cond` block with the test `t`; however, since we have keywords which are always truthy, it would be equally valid to use `:else` or `:default` as final fallback tests. + +#### (lambda (arg ...) form ...), (λ (arg ...) form ...) + +Returns an anonymous fuction which evaluates each of the *form*s sequentially in an environment in which the specified *arg*s are bound, and returns the value of the last such form. + +#### (let ((*var* . *val*) ...) form ...) + +Evaluates each of these *form*s sequentially in an environment in which each *var* is bound to the respective *val* in the bindings specified, and returns the value of the last form. + +#### (nlambda (arg ...) form ...), (nλ (arg ...) form ...) + +Returns an anonymous special form which evaluates each of the *form*s sequentially in an environment in which the specified *arg*s are bound, and returns the value of the last such form. + +#### (progn *f* ...) + +Evaluates each of the forms which are its arguments in turn and returns the value of the last. + +#### (quote *o*), '*o* + +Returns *o*, unevaluated. + +#### (set! *name* *value* [*namespace*]) + +Sets (destructively modifies) the value of *name* this *value* in the root namespace. The *namespace* argument is currently ignored but in future is anticipated to be a path specification of a namespace to be modified. + +#### (try (*form* ...) (*handler* ...)) + +Attempt to evaluate, sequentially, each of the *form*s in the first sequence, and return the value of the last of them; however, if any of them cause an exception to be thrown, then evaluate sequentially each of the *handler*s in the second sequence. + +It is recommended that you structure this as follows: + +`lisp + (try + (:body + (print "hello") + (/ 1 'a) + (print "goodbye")) + (:catch + (print "Well, that failed.") + 5)) +` + +Here, `:body` and `:catch` are syntactic sugar which will not affect the final value. + +### Type values The following types are known. Further types can be defined, and ultimately it should be possible to define further types in Lisp, but these are what you have to be going on with. Note that where this documentation differs from `memory/consspaceobject.h`, this documentation is *wrong*. @@ -261,7 +367,7 @@ A symbol is just like a string except not self-evaluating. Later, there may be s #### TIME -A time stamp. Not really properly implemented yet; the epoch is not defined, and, given the size of numbers we can store, could be pushed far into the past. +A time stamp. The epoch for the Post Scarcity Software Environment is 14 billion years before the UN*X epoch, and is chosen as being a reasonable estimate for the birth of the universe, and thus of the start of time. #### TRUE diff --git a/src/init.c b/src/init.c index dee2b7c..676964f 100644 --- a/src/init.c +++ b/src/init.c @@ -247,9 +247,8 @@ int main( int argc, char *argv[] ) { bind_function( L"oblist", &lisp_oblist ); bind_function( L"open", &lisp_open ); bind_function( L"print", &lisp_print ); - bind_function( L"progn", &lisp_progn ); - bind_function( L"put", lisp_hashmap_put ); - bind_function( L"put-all", &lisp_hashmap_put_all ); + bind_function( L"put!", lisp_hashmap_put ); + bind_function( L"put-all!", &lisp_hashmap_put_all ); bind_function( L"read", &lisp_read ); bind_function( L"read-char", &lisp_read_char ); bind_function( L"repl", &lisp_repl ); diff --git a/src/ops/lispops.c b/src/ops/lispops.c index 917f7b5..f9fb95a 100644 --- a/src/ops/lispops.c +++ b/src/ops/lispops.c @@ -1256,23 +1256,36 @@ struct cons_pointer lisp_repl( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ) { struct cons_pointer expr = NIL; - - /* \todo bind *prompt*, *input*, *output* in the environment to the values - * of arguments 0, 1, and 2 respectively, but in each case only if the - * argument is not nil */ + + debug_printf(DEBUG_REPL, L"Entering new inner REPL\n"); struct cons_pointer input = get_default_stream( true, env ); struct cons_pointer output = get_default_stream( false, env ); - URL_FILE *os = pointer2cell( output ).payload.stream.stream; struct cons_pointer prompt_name = c_string_to_lisp_symbol( L"*prompt*" ); struct cons_pointer old_oblist = oblist; struct cons_pointer new_env = env; + inc_ref( env ); + if (truep(frame->arg[0])) { + new_env = set( prompt_name, frame->arg[0], new_env); + } + if (readp(frame->arg[1])) { + new_env = set( c_string_to_lisp_symbol(L"*in*"), frame->arg[1], new_env); + input = frame->arg[1]; + } + if (readp(frame->arg[2])) { + new_env = set( c_string_to_lisp_symbol(L"*out*"), frame->arg[2], new_env); + output = frame->arg[2]; + } + inc_ref( input ); inc_ref( output ); inc_ref( prompt_name ); + URL_FILE *os = pointer2cell( output ).payload.stream.stream; + + /* \todo this is subtly wrong. If we were evaluating * (print (eval (read))) * then the stack frame for read would have the stack frame for @@ -1287,6 +1300,8 @@ struct cons_pointer lisp_repl( struct stack_frame *frame, * are not visible. So copy changes made in the oblist into the enviroment. * \todo the whole process of resolving symbol values needs to be revisited * when we get onto namespaces. */ + /* OK, there's something even more subtle here if the root namespace is a map. + * H'mmmm... */ if ( !eq( oblist, old_oblist ) ) { struct cons_pointer cursor = oblist; @@ -1335,6 +1350,8 @@ struct cons_pointer lisp_repl( struct stack_frame *frame, dec_ref( prompt_name ); dec_ref( env ); + debug_printf(DEBUG_REPL, L"Leaving inner repl\n"); + return expr; } From c2ad3eda0d6a1ee6d3f87d7fd22669800e172bdd Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Sun, 12 Sep 2021 19:01:51 +0100 Subject: [PATCH 28/28] Still trying to fix the damned README! --- README.md | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/README.md b/README.md index 93ad64d..8ea4dc4 100644 --- a/README.md +++ b/README.md @@ -6,7 +6,7 @@ tl,dr: look at the [wiki](wiki). ### Version 0.0.5 -Has working Lisp interpreter, more or less complete, with functions and symbols as defined under [#bindings currently available](Bindings currently available) below. Features include hash maps. +Has working Lisp interpreter, more or less complete, with functions and symbols as defined under [#bindings-currently-available](Bindings currently available) below. Features include hash maps. #### Known bugs