~trn/reduce-algebra

fab497f6ccd160cc7efc5313112e1ce1f6008d71 — Jeffrey H. Johnson a day ago 2914b55 + 1f7c2d5 master
Merge branch 'svn/trunk'
M packages/assert/assert.red => packages/assert/assert.red +255 -169
@@ 1,8 1,8 @@
module assert;

% ----------------------------------------------------------------------
% Copyright (c) 2010-2017 T. Sturm
% ----------------------------------------------------------------------
% $Id$
% (c) 2010-2021 T. Sturm, Germany

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions
% are met:


@@ 28,9 28,7 @@ module assert;
% OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
%

% $Id$

create!-package('(assert assertcheckfn assertproc),nil);
create!-package('(assert assertcheckfn assertproc), nil);

fluid '(assert_functionl!*);



@@ 48,79 46,135 @@ fluid '(lispsystem!*);
fluid '(assertstatistics!*);
fluid '(fname!*);

% The switch assert is a hook to make all stats introduced here return nil.
% formassert, in contrast, return '(cond (nil nil)) instead, because nil causes
% problems within progs. Note that even when assen is on, structs and asserted
% procedures only modify property lists but do not change the behaviour of the
% system unless assert_install or assert_install_all is used. Similarly, the
% code generated for assert() is once more protected by the switch evalassert.

switch assert;
fluid '(!*backtrace);

switch assert_inline_procedures;
% Translation time configuration:

on1 'assert_inline_procedures;
switch assert;
% The switch assert is a main switch. When it is off, all assertions are ignored to the most
% possible extent at translation time:
% 1. For "asserted procedure" and "asserted inline procedure", no assertion-related code is
%    generated at all.
% 2. formassert for the ASSERT( ... ) statement introduces '(cond (nil nil)). Note that introducing
%    nil causes problems within progs.
% Even when assert is on, evaulation of assertions depends on further switches and commands,
% introduced below.

put('assert, 'simpfg, '((t (assert_onoff)) (nil (assert_onoff))));

procedure assert_onoff();
   % This is for autoloading;
   % For autoloading
   ;

if getenv("REDUCE_ASSERT") then on1 'assert else off1 'assert;

switch evalassert, assertbreak, assertstatistics;

on1 'evalassert;
off1 'assertbreak;
on1 'assertstatistics;

procedure assert_check1(fn,origfn,argl,argtypel,restype);
   % This is the wrapper code executed when an insertion is installed.
   % fn is the name of the original function; origfn is an identifier
   % having the original function as its function value; argl is the
   % list of arguments passed; argtypel is a list of types asserted for
   % the arguments in argl; restype is the type asserted for the result
   % of the function call. Depending on the swith !*assertstatistics,
   % there is statictical information added to the fluid
   % assertstatistics!*, which is output and deleted when calling
   % assert_analyze().
   begin scalar cfn,w,res,scargtypel,bad; integer n;
switch assert_procedures, assert_inline_procedures;
% When off, The stat functions for "asserted procedure" and "asserted inline procedure" return nil,
% so that no assertion-related code is generated at all. When assert_inline_procedures is on (and
% the switch "assert" above, too), inline procedures are translated as expr procedures.

% Default settings for the switches depend on some environment variables. This allows automatic
% testing without modification of test files.

if getenv("REDUCE_ASSERT_LEVEL") = "1" then <<
   on1 'assert;
   off1 'assert_procedures;
   off1 'assert_inline_procedures
>> else if getenv("REDUCE_ASSERT_LEVEL") = "2" then <<
   on1 'assert;
   on1 'assert_procedures;
   off1 'assert_inline_procedures
>> else if getenv("REDUCE_ASSERT_LEVEL") = "3" then <<
   on1 'assert;
   on1 'assert_procedures;
   on1 'assert_inline_procedures
>> else <<
   off1 'assert
>>;

% Runtime configuration:

switch assertinstall;
% For asserted procedures, the assertions can be installed and uninstalled at runtime using
% assert_[un]install proc_1, .., proc_n  or  assert_[un]install_all()
% Technically, these commands exchange the function value of identifier (using copyd). Variants with
% and without assertions are kept on the property lists, and the latter is exactly the code that
% would habe been created without any assertions. The idea behind this is that assertion checking
% for some frequently called functions could slow down the computation too much.
%
% The switch assertinstall specifies the default choice for all functions. Turning it on is
% probably the only way to make sure assertions are active on all asserted procedures, because
% assert_install_all() can only know what has been loaded, and autoload is not assertion-aware. All
% requires some re-thinking.

switch evalassert;
% When active, the ASSERT( ... ) statement generates code "if !*evalassert then ...". The switch
% can thus be used to toggle the assertion test at runtime.

if getenv("REDUCE_ASSERT_LEVEL") member '("1" "2" "3") then <<
   on1 'assertinstall;
   on1 'evalassert
>> else <<
   off1 'assertinstall;
   off1 'evalassert
>>;

switch assertbreak, assertstatistics;
% When assertbreak is on, assertion violations raise an error and evaluation stops. When assertbreak
% is off, only a warning message is printed, and evaluation continues. With assertbreak off, it
% makes sense to turn on assertstatistics. Then, in addition to the warning messages, assertion
% violations are counted by procedure. The collected information can be printed at the end using
% assert_analyze().

if getenv("REDUCE_ASSERT_CONTINUE") = "1" then <<
   off1 'assertbreak;
   on1 'assertstatistics
>> else <<
   on1 'assertbreak;
   off1 'assertstatistics
>>;

procedure assert_check1(fn, origfn, argl, argtypel, restype);
   % This is the wrapper code executed when an insertion is installed. fn is the name of the
   % original function; origfn is an identifier having the original function as its function value;
   % argl is the list of arguments passed; argtypel is a list of types asserted for the arguments
   % in argl; restype is the type asserted for the result of the function call. Depending on the
   % swith !*assertstatistics, there is statictical information added to the fluid
   % assertstatistics!*, which is output and deleted when calling assert_analyze().
   begin scalar cfn, w, res, scargtypel, bad; integer n;
      if !*assertstatistics then <<
      	 w := atsoc(fn,assertstatistics!*);
      	 if w then
 	    cadr w := cadr w + 1
      	 else
 	    assertstatistics!* := (fn . {1,0,0}) . assertstatistics!*
         w := atsoc(fn, assertstatistics!*);
         if w then
            cadr w := cadr w + 1
         else
            assertstatistics!* := (fn . {1, 0, 0}) . assertstatistics!*
      >>;
      scargtypel := argtypel;
      for each a in argl do <<
	 n := n + 1;
	 if (cfn := get(car scargtypel,'assert_dyntypechk))
 	    and not apply(cfn,{a})
	    and not(pairp a and flagp(car a,'assert_ignore))
 	 then <<
	    bad := t;
	    assert_error(fn,argtypel,restype,n,car scargtypel,a)
	 >>;
	 scargtypel := cdr scargtypel
         n := n + 1;
         if (cfn := get(car scargtypel, 'assert_dyntypechk))
            and not apply(cfn, {a})
            and not(pairp a and flagp(car a, 'assert_ignore))
         then <<
            bad := t;
            assert_error(fn, argtypel, restype, n, argl, res)
         >>;
         scargtypel := cdr scargtypel
      >>;
      res := apply(origfn,argl);
      if (cfn := get(restype,'assert_dyntypechk))
	 and not apply(cfn,{res})
	 and not(pairp res and flagp(car res,'assert_ignore))
      res := apply(origfn, argl);
      if (cfn := get(restype, 'assert_dyntypechk))
         and not apply(cfn, {res})
         and not(pairp res and flagp(car res, 'assert_ignore))
      then <<
	 bad := t;
	 assert_error(fn,argtypel,restype,0,restype,res)
         bad := t;
         assert_error(fn, argtypel, restype, 0, argl, res)
      >>;
      if !*assertstatistics and bad then <<
      	 w := cdr atsoc(fn,assertstatistics!*);
	 cadr w := cadr w + 1
         w := cdr atsoc(fn, assertstatistics!*);
         cadr w := cadr w + 1
      >>;
      return res
   end;

procedure assert_error(fn,argtypel,restype,typeno,type,arg);
procedure assert_error(fn, argtypel, restype, typeno, argl, res);
   % Subroutine of assert_check1 called in case of an assertion violation. fn is
   % the name of the original function; argtypel is a list of types asserted for
   % the arguments of the function call; restype is the type asserted for the


@@ 131,36 185,67 @@ procedure assert_error(fn,argtypel,restype,typeno,type,arg);
   % interrupted with a rederr or computation continues and the error message is
   % printed as a warning. In the latter case lprim is used, which is controlled
   % by the switch !*msg.
   begin scalar w,msg,!*lower;
   begin scalar w, stars, !*lower;
      if !*assertstatistics then <<
      	 w := cdr atsoc(fn,assertstatistics!*);
	 caddr w := caddr w + 1
         w := cdr atsoc(fn, assertstatistics!*);
         caddr w := caddr w + 1
      >>;
      msg := if eqn(typeno,0) then
	 {"declaration",assert_format(fn,argtypel,restype),
	    "violated by result",arg}
      else
	 {"declaration",assert_format(fn,argtypel,restype),
	    "violated by",mkid('arg,typeno),arg};
      terpri();
      stars := if !*assertbreak then "***** " else "*** ";
      backtrace();
      terpri();
      prin2 fn;
      prin2t " being entered:";
      for i := 1 : length argl do <<
         prin2 "   ";
         prin2 mkid('a, i);
         prin2 ":   ";
         if i = typeno then
            prettyprint nth(argl, i)
         else
            print nth(argl, i)
      >>;
      if eqn(typeno, 0) then <<
         prin2 "returned:   ";
         prettyprint res
      >>;
      terpri();
      prin2 stars;
      prin2 "assertion ";
      prin2 assert_format(fn, argtypel, restype);
      prin2 " is violated by ";
      prin2 if eqn(typeno, 0) then "result" else mkid('a, typeno);
      if ifl!* then <<
         prin2 " ";
         prin2 "(at ";
         prin2 car ifl!*;
         prin2 ":";
         prin2 curline!*;
         prin2 ")"
      >>;
      terpri();
      if !*assertbreak then
	 rederr msg
      else
	 lprim msg
         error1()
   end;

procedure assert_format(fn,argtypel,restype);
procedure assert_format(fn, argtypel, restype);
   % fn is the original function name; argtypel is the list of types asserted
   % for the arguments; restype is the type asserted for the result.
   % Reconstructs the assertion as a identifier for printing in diagnostic
   % messages.
   begin scalar ass;
      ass := explode restype;
      ass := '!! . '!) . '!! . '! . '!! . '!- . '!! . '!> . '!! . '! . ass;
      ass := '!! . '!' . ass;
      if restype then <<
         ass := nconc(explode restype, ass);
         ass := '!! . '!: . '!! . '!  . ass
      >>;
      ass := '!! . '!) . ass;
      for each a in reverse argtypel do
	 ass := '!! . '!, . '!! . '!  . nconc(explode a,ass);
         ass := '!! . '!, . '!! . '!  . nconc(explode a, ass);
      ass := cddddr ass;
      ass := '!! . '!: . '!! . '! . '!! . '!( . ass;
      ass := nconc(explode fn,ass);
      ass := '!! . '!( . ass;
      ass := nconc(explode fn, ass);
      ass := '!! . '!` . ass;
      return compress ass
   end;



@@ 171,26 256,26 @@ procedure assert_structstat();
      type := scan();
      typeflag := {'flag, mkquote {type}, ''assert_dyntype};
      scan();
      if flagp(cursym!*,'delim) then <<
%% 	 if not !*assert then
%% 	    return nil;
	 if !*msg then lprim {"struct",type,"is not checked"};
      	 return typeflag
      if flagp(cursym!*, 'delim) then <<
%%       if not !*assert then
%%          return nil;
         if !*msg then lprim {"struct", type, "is not checked"};
         return typeflag
      >>;
      if cursym!* neq 'checked and cursym!* neq 'asserted then
	 rederr {"expecting 'asserted by' in struct but found",cursym!*};
         rederr {"expecting 'asserted by' in struct but found", cursym!*};
      if scan() neq 'by then
	 rederr {"expecting 'by' in struct but found",cursym!*};
         rederr {"expecting 'by' in struct but found", cursym!*};
      cfn := scan();
      if not flagp(scan(),'delim) then
	 rederr {"expecting end of struct but found",cursym!*};
      if not flagp(scan(), 'delim) then
         rederr {"expecting end of struct but found", cursym!*};
%%       if not !*assert then
%% 	 return nil;
      typecheckform := {'put,mkquote type, ''assert_dyntypechk, mkquote cfn};
%%       return nil;
      typecheckform := {'put, mkquote type, ''assert_dyntypechk, mkquote cfn};
      return {'progn, typecheckform, typeflag}
   end;

put('struct,'stat,'assert_structstat);
put('struct, 'stat, 'assert_structstat);

procedure assert_dyntypep(s);
   idp s and flagp(s, 'assert_dyntype);


@@ 200,32 285,31 @@ operator assert_analyze;
procedure assert_analyze();
   % Print and delete the statistical information collected in the fluid
   % assertstatistics!*. This works in both algebraic and symbolic mode.
   begin scalar headline,footline; integer s1,s2,s3;
      assertstatistics!* := sort(assertstatistics!*,
	 function(lambda x,y; ordp(car y,car x)));
   begin scalar headline, footline; integer s1, s2, s3;
      assertstatistics!* := sort(assertstatistics!*, function(lambda x, y; ordp(car y, car x)));
      for each pr in assertstatistics!* do <<
	 s1 := s1 + cadr pr;
	 s2 := s2 + caddr pr;
	 s3 := s3 + cadddr pr
         s1 := s1 + cadr pr;
         s2 := s2 + caddr pr;
         s3 := s3 + cadddr pr
      >>;
      headline := '(function . (!#calls  !#bad! calls !#assertion! violations));
      footline := 'sum . {s1,s2,s3};
      footline := 'sum . {s1, s2, s3};
      assertstatistics!* := nil . headline . nil .
	 reversip(nil . footline . nil . assertstatistics!*);
         reversip(nil . footline . nil . assertstatistics!*);
      for each pr in assertstatistics!* do <<
	 if pr then <<
	    prin2 car pr;
	    for i := length explode2 car pr + length explode2 cadr pr : 23 do
 	       prin2 " ";
	    prin2 cadr pr;
	    for i := length explode2 caddr pr : 23 do prin2 " ";
	    prin2 caddr pr;
	    for i := length explode2 cadddr pr : 23 do prin2 " ";
	    prin2t cadddr pr
	 >> else <<
	    for i := 1:72 do prin2 "-";
	    terpri()
	 >>
         if pr then <<
            prin2 car pr;
            for i := length explode2 car pr + length explode2 cadr pr : 23 do
               prin2 " ";
            prin2 cadr pr;
            for i := length explode2 caddr pr : 23 do prin2 " ";
            prin2 caddr pr;
            for i := length explode2 cadddr pr : 23 do prin2 " ";
            prin2t cadddr pr
         >> else <<
            for i := 1:72 do prin2 "-";
            terpri()
         >>
      >>;
      assertstatistics!* := nil
   end;


@@ 235,7 319,7 @@ procedure assert_declarestat();
   begin scalar l;
      l := assert_stat!-parse();
      if not !*assert then
	 return nil;
         return nil;
      return assert_declarestat1 l
   end;



@@ 243,40 327,43 @@ procedure assert_declarestat1(l);
   % Returns forms that define a suitable wrapper function, store relevant
   % information on the property list of the original function, and add the
   % original function to the global list assert_functionl!*.
   begin scalar fnx,progn,assertfn,noassertfn,argl,w1,w2,w3,w4,w5;
   begin scalar fnx, progn, assertfn, noassertfn, argl, w1, w2, w3, w4, w5;
      integer i;
      fnx := explode car l;
      assertfn := intern compress nconc(explode 'assert!:,fnx);
      noassertfn := intern compress nconc(explode 'noassert!:,fnx);
      argl := for each x in cadr l collect mkid('a,i := i + 1);
      assertfn := intern compress nconc(explode 'assert!:, fnx);
      noassertfn := intern compress nconc(explode 'noassert!:, fnx);
      argl := for each x in cadr l collect mkid('a, i := i + 1);
      w1 := mkquote car l;
      w2 := mkquote noassertfn;
      w3 := 'list . argl;
      w4 := 'list . for each fn in cadr l collect mkquote fn;
      w5 := mkquote caddr l;
      progn := {'de,assertfn,argl,{'assert_check1,w1,w2,w3,w4,w5}} . progn;
      progn := {'put,w1,''assert_assertfn,mkquote assertfn} . progn;
      progn := {'put,w1,''assert_noassertfn,w2} . progn;
      progn := {'put,w1,''assert_installed,nil} . progn;
      progn := {'cond,{
	 {'not,{'member,w1,'assert_functionl!*}},
	 {'setq,'assert_functionl!*,{'cons,w1,'assert_functionl!*}}}} . progn;
      progn := {'de, assertfn, argl, {'assert_check1, w1, w2, w3, w4, w5}} . progn;
      progn := {'put, w1, ''assert_assertfn, mkquote assertfn} . progn;
      progn := {'put, w1, ''assert_noassertfn, w2} . progn;
      progn := {'put, w1, ''assert_installed, nil} . progn;
      progn := {'cond, {
         {'not, {'member, w1, 'assert_functionl!*}},
         {'setq, 'assert_functionl!*, {'cons, w1, 'assert_functionl!*}}}} . progn;
      if !*assertinstall then <<
         progn := {'assert_install1, mkquote car l} . progn
      >>;
      return 'progn . reversip progn
   end;

procedure assert_stat!-parse();
   % Subroutine of assert_stat(). This is the actual parsing code.
   begin scalar fn,argtypel,restype;
   begin scalar fn, argtypel, restype;
      fn := scan();
      if scan() neq '!*colon!* then
	 rederr {"expecting ':' in assert but found",cursym!*};
         rederr {"expecting ':' in assert but found", cursym!*};
      argtypel := assert_stat1();
      if scan() neq 'difference or scan() neq 'greaterp then
	 rederr {"expecting '->' in assert but found",cursym!*};
         rederr {"expecting '->' in assert but found", cursym!*};
      restype := scan();
      if not flagp(scan(),'delim) then
	 rederr {"expecting end of assert but found",cursym!*};
      return {fn,argtypel,restype}
      if not flagp(scan(), 'delim) then
         rederr {"expecting end of assert but found", cursym!*};
      return {fn, argtypel, restype}
   end;

procedure assert_stat1();


@@ 284,21 371,21 @@ procedure assert_stat1();
   % types left of the arrow.
   begin scalar argtypel;
      if scan() neq '!*lpar!* then
	 rederr {"expecting '(' in assert but found",cursym!*};
         rederr {"expecting '(' in assert but found", cursym!*};
      if scan() eq '!*rpar!* then
	 return nil;
         return nil;
      repeat <<
	 argtypel := cursym!* . argtypel;
	 scan();
      	 if cursym!* neq '!*comma!* and cursym!* neq '!*rpar!* then
	    rederr {"expecting ',' or ')' in assert but found",cursym!*};
	 if cursym!* eq '!*comma!* then
	    scan()
         argtypel := cursym!* . argtypel;
         scan();
         if cursym!* neq '!*comma!* and cursym!* neq '!*rpar!* then
            rederr {"expecting ', ' or ')' in assert but found", cursym!*};
         if cursym!* eq '!*comma!* then
            scan()
      >> until cursym!* eq '!*rpar!*;
      return reversip argtypel
   end;

put('declare,'stat,'assert_declarestat);
put('declare, 'stat, 'assert_declarestat);

procedure assert_install(fnl);
   % This is parsed as stat rlis, i.e., it takes a comma-separated list


@@ 307,19 394,19 @@ procedure assert_install(fnl);
   % installed.
   for each fn in fnl do assert_install1 fn;

put('assert_install,'stat,'rlis);
put('assert_install, 'stat, 'rlis);

procedure assert_install1(fn);
   % fn is an identifier that is a single function for which an existing
   % assertion is installed.
   if get(fn,'assert_installed) then
      lprim {"assert already installed for",fn}
   else if not eqcar(getd fn,'expr) then
      lprim {fn,"is not an expr procedure - ignoring assert"}
   if get(fn, 'assert_installed) then
      lprim {"assert already installed for", fn}
   else if not eqcar(getd fn, 'expr) then
      lprim {fn, "is not an expr procedure - ignoring assert"}
   else <<
      copyd(get(fn,'assert_noassertfn),fn);
      copyd(fn,get(fn,'assert_assertfn));
      put(fn,'assert_installed,t)
      copyd(get(fn, 'assert_noassertfn), fn);
      copyd(fn, get(fn, 'assert_assertfn));
      put(fn, 'assert_installed, t)
   >>;

procedure assert_uninstall(fnl);


@@ 329,16 416,16 @@ procedure assert_uninstall(fnl);
   % uninstalled.
   for each fn in fnl do assert_uninstall1 fn;

put('assert_uninstall,'stat,'rlis);
put('assert_uninstall, 'stat, 'rlis);

procedure assert_uninstall1(fn);
   % fn is an identifier that is a single function for which an
   % installed assertion is uninstalled.
   if not get(fn,'assert_installed) then
      lprim {"assert not installed for",fn}
   if not get(fn, 'assert_installed) then
      lprim {"assert not installed for", fn}
   else <<
      copyd(fn,get(fn,'assert_noassertfn));
      put(fn,'assert_installed,nil)
      copyd(fn, get(fn, 'assert_noassertfn));
      put(fn, 'assert_installed, nil)
   >>;

operator assert_install_all;


@@ 349,9 436,9 @@ procedure assert_install_all();
   % functions in the global list assert_functionl!* of all functions
   % for which there are assertions defined.
   for each fn in assert_functionl!* do
      if not get(fn,'assert_installed) then <<
	 lprim {"assert_install", fn};
	 assert_install1 fn
      if not get(fn, 'assert_installed) then <<
         lprim {"assert_install", fn};
         assert_install1 fn
      >>;

operator assert_uninstall_all;


@@ 362,14 449,14 @@ procedure assert_uninstall_all();
   % functions in the global list assert_functionl!* of all functions
   % for which ther are assertions defined.
   for each fn in assert_functionl!* do
      if get(fn,'assert_installed) then <<
	 lprim {"assert_uninstall", fn};
      	 assert_uninstall1 fn
      if get(fn, 'assert_installed) then <<
         lprim {"assert_uninstall", fn};
         assert_uninstall1 fn
      >>;

procedure formassert(u,vars,mode);
procedure formassert(u, vars, mode);
   if mode eq 'symbolic and !*assert then
      assert_assert(u,vars,mode)
      assert_assert(u, vars, mode)
   else
      '(cond (nil nil));



@@ 382,12 469,11 @@ procedure assert_assert(u, vars, mode);
      a := u;
      m := {"assertion", mkquote cadr a, "violated in procedure", mkquote fname!*};
      if ifl!* then
	 m := assert_sconcat {car ifl!*, ":", assert_at2str curline!*, ":"} . m;
         m := assert_sconcat {car ifl!*, ":", assert_at2str curline!*, ":"} . m;
      m := 'list . m;
      return {'cond, {{'and, '!*evalassert, {'not, formc(cadr u, vars, mode)}},
	 {'progn,
	    {'cond, {'!*backtrace, {'backtrace}}},
	    {'cond, {'!*assertbreak, {'rederr, m}}, {t, {'lprim, m}}}}}}
                      {'progn, {'cond, {'!*backtrace, {'backtrace}}},
                               {'cond, {'!*assertbreak, {'rederr, m}}, {t, {'lprim, m}}}}}}
   end;

procedure assert_outl2string(outl);


@@ 403,16 489,16 @@ procedure assert_string2idl(s);
      {'!!, '! }
   else
      for each c in explode s join
       	 if eq(c, '!") or eq(c, '! ) then {'!!, c} else {c};
         if eq(c, '!") or eq(c, '! ) then {'!!, c} else {c};

% The following are copies of rltools/lto.red, because I do not want to depend
% on other modules here:

procedure assert_sconcat2(s1,s2);
procedure assert_sconcat2(s1, s2);
   % List tools string concatenation 2. [s1] and [s2] are strings.
   % Returns a string. The returned string is the concatenation
   % [s1][s2].
   compress append(reversip cdr reversip explode s1,cdr explode s2);
   compress append(reversip cdr reversip explode s1, cdr explode s2);

procedure assert_sconcat(l);
   % List tools string concatenation. [l] is a list of strings.


@@ 420,9 506,9 @@ procedure assert_sconcat(l);
   % strings in [l].
   if l then
      if cdr l then
 	 assert_sconcat2(car l, assert_sconcat cdr l)
         assert_sconcat2(car l, assert_sconcat cdr l)
      else
	 car l;
         car l;

procedure assert_at2str(s);
   % List tools atom to string. [s] is an atom. Returns the print name


@@ 439,6 525,6 @@ flag('(id2string), 'rlisp);

#endif

endmodule;  % assert
endmodule;

end;  % of file
end;

M packages/assert/assertcheckfn.red => packages/assert/assertcheckfn.red +17 -20
@@ 1,8 1,7 @@
% ----------------------------------------------------------------------
module assertcheckfn;
% $Id$
% ----------------------------------------------------------------------
% Copyright (c) 2010 Thomas Sturm
% ----------------------------------------------------------------------
% (c) 2010 Thomas Sturm

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions
% are met:


@@ 28,8 27,6 @@
% OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
%

module assertcheckfn;

compiletime on1 'assert;

% Primitive data types (2.1 of the SL Report)


@@ 141,30 138,30 @@ procedure sfpx1(u,vl,v,d,chkord);
   % korder!* and orderp.
   begin scalar c,l,p,r,vv; integer dd;
      if domainp u then
	 return t;
         return t;
      if not pairp u then
 	 return nil;
         return nil;
      % Decompose u as follows: u = l + r, l = c * p, p = vv ^ dd
      l := lt u;
      r := red u;
      if not pairp l then
 	 return nil;
         return nil;
      c := tc l;
      p := tpow l;
      if not pairp p then
 	 return nil;
         return nil;
      vv := car p;
      if not assert_kernelp vv then
	 return nil;
         return nil;
      dd := pdeg p;
      if vv eq v then
	 % We are considering a reductum and the variable has not changed.
	 return dd < d and
 	    sfpx1(c,v . vl,nil,0,chkord) and sfpx1(r,vl,v,dd,chkord);
         % We are considering a reductum and the variable has not changed.
         return dd < d and
            sfpx1(c,v . vl,nil,0,chkord) and sfpx1(r,vl,v,dd,chkord);
      % We are considering the original form or an lc, or a reductum
      % where the variable has changed from v to vv.
      if v then
	 vl := v . vl;
         vl := v . vl;
      % vv must be smaller than all variables in vl wrt. the current
      % kernel order. By recursion, vl is sorted so that it is
      % sufficient to compare with car vl. I construct linear powers in


@@ 172,19 169,19 @@ procedure sfpx1(u,vl,v,d,chkord);
      % directly comparing (possibly composite) kernels. The relevant
      % code is mostly in alg/order.red and hardly documented.
      if chkord and vl and ordpp(vv .** 1,car vl .** 1) then
	 % We have seen a smaller variable before.
	 return nil;
         % We have seen a smaller variable before.
         return nil;
      return sfpx1(c,vv . vl,nil,0,chkord) and sfpx1(r,vl,vv,dd,chkord)
   end;

procedure assert_kernelp(u);
   begin scalar w;
      if idp u then
 	 return t;
         return t;
      if not pairp u then
 	 return nil;
         return nil;
      if get(car u,'fkernfn) then
	 return t;
         return t;
      w := if atom car u then get(car u,'klist) else exlist!*;
      return atsoc(u,w)
   end;

M packages/assert/assertproc.red => packages/assert/assertproc.red +3 -12
@@ 1,8 1,7 @@
% ----------------------------------------------------------------------
module assertproc;
% $Id$
% ----------------------------------------------------------------------
% Copyright (c) 2012 Thomas Sturm
% ----------------------------------------------------------------------
% (c) 2012-2021 T. Sturm, Germany

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions
% are met:


@@ 28,14 27,6 @@
% OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
%

lisp <<
   fluid '(assertproc_rcsid!* assertproc_copyright!*);
   assertproc_rcsid!* := "$Id$";
   assertproc_copyright!* := "(c) 2012 T. Sturm"
>>;

module assertproc;

procedure assert_procstat();
   begin scalar ftype, fname, w, body;
      scan();

M packages/support/entry.red => packages/support/entry.red +3 -0
@@ 823,6 823,9 @@ defautoload(assert_install_all, assert, expr, 0);
operator assert_uninstall_all;
defautoload(assert_uninstall_all, assert, expr, 0);

defautoload(assert_install1, assert, expr, 1);
defautoload(sqp, assert, expr, 1);

% LALR

defautoload(lex_cleanup, lalr, expr, 0);

M packages/support/revision.red => packages/support/revision.red +1 -1
@@ 31,6 31,6 @@

fluid '(revision!*);

revision!* := 6025;
revision!* := 6027;

end;

A psl/dist/comp/win32/win32-asm.sl => psl/dist/comp/win32/win32-asm.sl +587 -0
@@ 0,0 1,587 @@
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%
% File:         PXC:winnt-ASM.SL
% Description:  Windows NT 386 specific information for LAP-TO-ASM
% Author:       
% Created:      16-Jan-1993
% Modified:
% Mode:         Lisp
% Status:       Open Source: BSD License
%
%
% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%
% Revisions:
%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

(compiletime (load if-system))

(global '($eol$))

(Fluid '(CodeFileNameFormat* 
	 DataFileNameFormat* 
	 InitFileNameFormat* 
	 InputSymFile* 
	 OutputSymFile* 
	 CommentFormat* 
	 GlobalDataFileName* 
	 LabelFormat* 
	 ExternalDeclarationFormat* 
	 ExportedDeclarationFormat* 
	 FullWordFormat* 
	 HalfWordFormat* 
	 ReserveDataBlockFormat* 
	 ReserveZeroBlockFormat* 
	 DefinedFunctionCellFormat* 
	 UndefinedFunctionCellInstructions* 
	 MainEntryPointName* 
	 CodeOut* 
	 DataOut* 
	 *Lower 
	 ASMOpenParen* 
	 ASMCloseParen* 
	 ModuleName* 
	 NumericRegisterNames* 
	 ForeignExternList* 
	 DataProcState* 
	 PathIn*
	 printexpressionform*
	 printexpressionformpointer*
	 *declarebeforeuse))

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% This assembler produces two files: a code file and a data file. Both  %
% of these files are assembled to reside in the dataspace               %
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%FORMATS%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

(setq *DeclareBeforeUse t)

(setq CodeFileNameFormat* "%w.s")        % The name of the code segment file
(setq DataFileNameFormat* "d%w.s")       % postfix the "d" so that the files
					 % [20] is a reasonable guess at aU
					 % size specification

(setq InitFileNameFormat* "%w.init")     % [20] is a reasonable guess at a
					 % size specification; it may need to
					 % be changed.

(setq InputSymFile* "sun386.sym")           % default for full-kernel-build
(setq OutputSymFile* "sun386.sym")

(setq MainEntryPointName* '!m!a!i!n)     % chose a simple default
					  % main procedure name

(setq NumericRegisterNames* '[nil "%eax" "%ebx" "%ecx" "%edx" "%ebp" ])

(setq LabelFormat* "%w:%n")          % Labels are in the first column
(setq dataLabelFormat* " %w:%n")
(setq CommentFormat* "/ %p%n")          % Comments begin with a slash
					% will group alphabetically

(setq ExportedDeclarationFormat* " .globl %w%n")
(setq ExternalDeclarationFormat* " .globl %w%n") % All in DATA space

(setq FullWordFormat* " .long %e%n")     % FullWord expects %e for parameter
(setq HalfWordFormat* " .word %e%n")     % Will EVAL formatter

(setq ReserveDataBlockFormat* " .bss %w,%e%n")
% This does *not* make zero blocks, however, the Sun manuals
% promise that a.out memory is init'ed to 0s
% Changed below to be like Vax version, so heap will be in bss. bao
(setq ReserveZeroBlockFormat* "  .comm %w,%e%n")

(put 'MkItem 'ASMExpressionFormat "((%e*0x8000000)+%e)" )

(setq DefinedFunctionCellFormat* " .long %w%n")   %/ Must be LONG

(setq UndefinedFunctionCellInstructions*   '(( !.long UndefinedFunction)))

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%LISTS and CONSTANT DEFINITIONS%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

(setq ASMOpenParen* "(")
(setq ASMCloseParen* ")")

(DefList '((LAnd &) (LOr !!)) 'BinaryASMOp)

(DefList '(     (t1 "%edi")
	  	(t2 "%esi") 
		(eax "%eax") (al "%al") (ax "%ax")
		(edx "%edx")
		(ecx "%ecx") (cl "%cl") (cx "%cx")
		(dl "dl") (ah "ah") (bx "bx") (ebx "%ebx")
		(edi "%edi") (esi "%esi")  (ebp "%ebp")
		(es "es") (cs "cs") (ds "ds") (ss "ss")
		(sp "%esp") (esp "%esp") (st "%esp") )  % Stack Pointer
  'RegisterName)


(setq DataProcState* 'data)

%%% This put is to associate the above code with (float x) in LAP

(put 'Float 'ASMPseudoOp 'ASMPseudoPrintFloat)

(de ASMPseudoPrintFloat (x)
  (cond ((EqN (cadr x) 0.0)
	 (printf "  .long 0%n  .long 0%n")
	)
	((EqN (cadr x) 1.0)
	 (printf "  .long 0x3ff00000%n  .long 0%n")
	)
  )
)

%%%%  % dont print operand size prefix for assembler
%%%%  % (is encoded in the register name already)
%%%%
%%%%(put 'OS: 'asmPseudoOp '(lambda(x) nil))

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%CODE HEADERS AND TRAILERS%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%


(de CodeFileHeader nil                  % Pure Code Segment
  (CodePrintF "        .text%n")
  (setq DataProcState* 'data) 
  (setq ForeignExternList* nil))
		
(de DataFileHeader nil 
  (DataPrintF "        .data%n")
 )


(de DataFileTrailer nil 
  nil)

(de CodeFileTrailer nil 
   nil)

(de CheckForeignExtern (Fn) 
  (cond
   ((not (Memq Fn ForeignExternList*))
    (setq ForeignExternList* (cons Fn ForeignExternList*)))))

(de CodeBlockHeader nil nil)            %/ Chuck this?
    

(de CodeBlockTrailer nil nil)
    

(de DataAlignFullWord nil nil)
  

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%`%%
% PRINT PROCEDURES%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%


(de PrintString (S) 
 (prog (n) 
    (cond
     ((neq (Size S) -1) 
      (progn (setq n (Size S)) 
	     (printf " .byte ") 
	     (PrintExpression (Indx S 0)) 
	     (for (from i 1 n 1)
		  (do (PrintByte!, (Indx S i))))
	     (PrintByte!, 0) 
	     (cond
	      ((equal (Remainder n 2) 1)
	       (PrintByte!, 0)))
	     (Terpri)
	     nil))
     (t 
      (progn 
	(printf " .byte ") 
	(PrintExpression 0) 
	(PrintByte!, 0) 
	(Terpri) nil)))))
 

(de PrintByte!, (x) 
  (progn (cond
	  ((greaterp (POSN) 40)
	   (printf "%n .byte "))
	  (t (Prin2 ","))) 
	 (PrintExpression x)))
    
(de TruncateString (S n) 
  (cond
   ((leq (Size S) n)
    S)
   (t
    (SUB S 0 n))))

(de PrintByteList (L) 
    (foreach x in L do (PrintByte x)))

(de PrintByte (x) 
  (progn (printf " .byte ") 
	 (PrintExpression x) 
	 (Prin2 $EOL$)))

(de PrintHalfWordList (L) 
    (foreach x in L do (PrintHalfWord x)))

(de PrintHalfWord (x) 
  (progn (printf " .word ") 
	 (PrintExpression x) 
	 (Prin2 $EOL$)))

(de PrintHalfWords (x) 
  (progn (RplacA PrintExpressionFormPointer* x) 
	 (printf HalfWordFormat* PrintExpressionForm*)))


(put 'HalfWord 'asmpseudoop 'ASMPseudoPrintHalfWords)

(de ASMPseudoPrintHalfWords (x) 
    (foreach Y in (cdr x) do (PrintHalfWord Y)))


(fluid '(*sun-mnemonic-change-table*))

%%% Print out an opcode id (derived from LAP)
%%% The x86 requires a number of transformations to the opcodes
%%% Must change to lower case, take out the . separator, and
%%% change the names of certain mnemonics...

(de PrintOpcode (opcode)
  (let ((xform (atsoc opcode *sun-mnemonic-change-table*)))
    (if xform (setq opcode (cdr xform)))
    (prin2 (eval `(string 
	     ,@(for (in x (delete 246 (string2list (id2string opcode))))
% ausser Gefecht w.n.
		    (collect (asm-char-downcase x))
	       )
		  )
	   )
    )
  )
)

%%% Taken from PU:chars.lsp, this routine converts a character (a small
%%% number) from uppercase to lowercase.  This version is considerably
%%% simplified from the PU: one so that it works in a bare PSL (a primitive
%%% if there ever was one)

(de asm-char-downcase (c)
  (if (not (or (lessp c (char !A)) (greaterp c (char !Z))))
      (plus (char !a) (difference c (char !A)))
      c
  )
)

%%% Mapping table for the mnemonics that Sun decided to "improve"

(setq *sun-mnemonic-change-table*
  '(
    %(cdq     . cltd )
    %(cwde    . cwtl )
    %(cbw     . cbtw )
   )
)


(de SpecialActionForMainEntryPoint nil 
  (progn (CodePrintLabel MainEntryPointName*) 
	 (CodeDeclareExported MainEntryPointName*)))


%%% Predicate to decide whether the given id or string is a valid
%%% one to the machine's assembler (though what lap-to-asm does if
%%% this predicate fails is beyond me!)

(de ASMSymbolP (x)
  (SunSymbolP (if (idp x) (id2string x) x))
)

(de SunSymbolP (x)
  (let ((n (size x))
	(c (indx x 0))
       )
    (and (geq n 0)  % empty strings not valid
	 (or (and (geq c (char A)) (leq c (char Z)))
	     (and (geq c (char !a)) (leq c (char !z)))
	     (eqn c (char !_))
	 )
	 (for (from i 1 n)
	      (with (rslt t))
	      (while rslt)
	      (do (setq c (indx x i))
		  (setq rslt (or (and (geq c (char A)) (leq c (char Z)))
				 (and (geq c (char !a)) (leq c (char !z)))
				 (eqn c (char !_))
			     )
		  )
	      )
	      (returns rslt)
	 )
    )
  )
)


%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

(de PrintNumericOperand (x) 
  (printf "$%w" x))


(de OperandPrintIndirect (x)            % (Indirect x)
  (progn (setq x (cadr x)) 
	 (if (regp x) (progn
			(prin2 "(")
			(PrintOperand x) 
			(Prin2 ")"))
	       (prin2 "*")
	       (PrintOperand x)
	       (Prin2 "")) 
))

(put 'Indirect 'OperandPrintFunction 'OperandPrintIndirect)

%%%%(de OperandPrintOffset (x)
%%%%    (prin2 "OFFSET " ) (printoperand (cadr x)))
%%%%
%%%%(put 'offset 'OperandPrintFunction 'OperandPrintOffset)

(de OperandPrintDisplacement (x)        % (Displacement (reg x) disp)
   (progn (setq x (cdr x)) 
	  (PrintExpression (cadr x)) 
	  (Prin2 "(")
	  (Printoperand (car x)) 
	  (Prin2 ")")))

(put 'displacement 'OperandPrintFunction 'OperandPrintDisplacement)

% (Indexed (reg y)(displacement (reg x) disp))
% or       (times (reg y) 1/2/4/8) (displacement (reg x) disp))
% or       (times (reg y) 1/2/4/8) lab)   for jumpon
%
(de OperandPrintIndexed (x)  % (indexed (reg y) (displacement (reg x) disp))
  (if (regp (second x))
    (let ((part2 (third x)))
       (printexpression (third part2))
       (prin2 "(")
       (PrintRegister (cadr part2))
       (prin2 ",")
       (PrintRegister (cadr x))
       (prin2 ",1)")))
  (if (eqcar (second x) 'times)
   (let ((part2 (third x))
	 (part1 (second x)))
       (if (atom part2)
	   (progn  (printexpression part2))
	   (printexpression (third part2)))
       (prin2 "(")
       (when (pairp part2) (PrintRegister (cadr part2)))
       (prin2 ",")
       (PrintRegister (cadr part1))
       (prin2 ",")
       (when (not (memq (third part1) '(1 2 4 8)))
	     (error 199 "Wrong Indexed mode"))
       (prin2 (third part1))
       (prin2 ")")))
)

(put 'Indexed 'OperandPrintFunction 'OperandPrintIndexed)

(de OperandPrintImmediate (x)           % (Immediate x) % for ADDRESS
  (progn %(prin2 "#")
	 (PrintExpression (cadr x))))

(put 'Immediate 'OperandPrintFunction 'OperandPrintImmediate)


(de OperandPrintPostIncrement (x)       % (PostIncrement x)
  (progn (PrintOperand (cadr x)) 
	 (Prin2 "@+")))

(put 'PostIncrement 'OperandPrintFunction 'OperandPrintPostIncrement)

(de OperandPrintRegList (x)             % (Reglist x)
  (progn (setq x (cdr x)) 
	 (PrintOperand (car x)) 
	 (setq x (cdr x)) 
	 (While x 
		(progn (Prin2 "/") 
		       (PrintOperand (car x)) 
		       (setq x (cdr x)))) nil))


(put 'RegList 'OperandPrintFunction 'OperandPrintRegList)

(de OperandPrintPreDecrement (x)        % (PreDecrement x)
  (progn (PrintOperand (cadr x)) 
	 (Prin2 "@-")))

(put 'PreDecrement 'OperandPrintFunction 'OperandPrintPreDecrement)

(de OperandPrintAbsolute (x)            % (Absolute x)
    (PrintExpression (cadr x)))


(put 'Absolute 'OperandPrintFunction 'OperandPrintAbsolute)

(de OperandPrintForeignEntry (x)        % (ForeignEntry FcnName)
  (let ((*lower t))
       (printf "%w" (cadr x))))
  
(put 'ForeignEntry 'OperandPrintFunction 'OperandPrintForeignEntry)

(Fluid '(ResultingCode*))

(de MCPrint (x)                         % Echo of MC's
 (CodePrintF "/ %p%n" x))

(de InstructionPrint (x) 
 (CodePrintF "/    %p%n" x))

(de *cerror (x) 
 (prog (i) 
    (setq i (wrs nil)) 
    (printf "%n *** CERROR: %r %n " x) 
    (wrs i) 
    (return (list (list 'cerror x)))))
 

(put 'cerror 'asmpseudoop 'printcomment)

(DefCMacro *cerror)

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% A HORRID patch for BRA/BRA!.W incompatibility between
% KERNEL and LAP
% In Kernel, BRA means word sized branch
% IN LAp and FASL BRA seems to mean bytes sized (?) even though
% must be coerced somewhere
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%@%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%


(de datareserveblock (x)
  (dataprintf "  .space %w%n" (times x addressingunitsperitem)))

% (rplaca printexpressionformpointer*
%         (list 'times2 (compiler-constant 'addressingunitsperitem) x))
% (dataprintf reservedatablockformat* (gensym) printexpressionform*))

(de datareservefunctioncellblock (x)
   (dataprintf "  .space %w%n" (times x addressingunitsperitem)))

% (rplaca printexpressionformpointer*
%         (list 'times2 (compiler-constant 'addressingunitsperfunctioncell) x))
% (dataprintf reservedatablockformat* (gensym) printexpressionform*))


(de initializesymboltable ()
  (let ((maxsymbol (compiler-constant 'maxsymbols)) olddataout)
    (when (lessp maxsymbol nextidnumber*)
      (errorprintf "*** MaxSymbols %r is too small; at least %r are needed"
		   maxsymbol nextidnumber*)
      (setq maxsymbol (plus nextidnumber* 100)))
    (flag '(nil) 'nilinitialvalue)
    (put 't 'initialvalue 't)
    (setq nilnumber* (compileconstant nil))
    (dataalignfullword)
    (initializesymval)
    (datareserveblock (plus (difference maxsymbol nextidnumber*) 1))
    (initializesymprp)
    (datareserveblock (plus (difference maxsymbol nextidnumber*) 1))
    (initializesymnam)
    (datareserveblock (plus (difference maxsymbol nextidnumber*) 1))
    (initializesymfnc)
    (datareservefunctioncellblock
     (plus (difference maxsymbol nextidnumber*) 1))
    (initializesymget)   % SYMGET feature
    (datareserveblock (plus (difference maxsymbol nextidnumber*) 1))
%    (dataalignfullword)
%    (dataprintgloballabel (findgloballabel 'nextsymbol))
%    (dataprintfullword nextidnumber*)
    ))

(de asmoutlap1 (x)
  (prog (fn)
	(return (cond ((stringp x) (printlabel x))
		      ((atom x) (printlabel (findlocallabel x)))
		      ((setq fn (get (car x) 'asmpseudoop)) 
		       (apply fn (list x)))
		      (t
		       % instruction output form is:
      % "space" <opcode> [ "space" <operand> { "comma" <operand> } ] "newline"
									   
      (progn (prin2 '! )
	     % Space                                    
	     (printopcode (car x))
	     (setq x (cdr x))
	     (unless (null x)
		     (prin2 '! )
		     % SPACE 
		     (printoperand (car x))
		     (foreach u in (cdr x) do 
			      (progn (prin2 '!,)
				     % COMMA                          
				     (printoperand u))))
%	     (prin2 (int2id 13))
	     (prin2 !$eol!$)))))))

(de compileconstant (x)
  (setq x (buildconstant x))
  (if (null (cdr x))
    (car x)
    (progn (when *declarebeforeuse
	     (codedeclareexported (cadr x)))
	   (asmoutlap (cdr x))
           (datadeclareexternal (cadr x))
	   (unless *declarebeforeuse
	     (codedeclareexported (cadr x)))
	   (car x))))

(df declare-aux-1 (u)
  (foreach x in (cadar u) do 
    (declare-aux-2 (car x) (cadr x) )))

(de declare-aux-2 (name upperbound)
     (findidnumber name)             % generate an ID it doesn't exist.
     (put name 'symbol name)         % flag as a fluid variable.
     (put name 'type 'fluid)         % flag as a fluid variable.
     (flag1 name 'externalsymbol)     % flag as initial symbol value.
     (when *declarebeforeuse (datadeclareexported name))
%     (dataalignfullword)
     (setq upperbound (list 'plus2 upperbound 1))
     (datareservezeroblock name upperbound)
     (unless *declarebeforeuse (datadeclareexported name))
%     (codedeclareexternal name)
)
% End of file.


A psl/dist/nonkernel/win32/ieee-decls.sl => psl/dist/nonkernel/win32/ieee-decls.sl +86 -0
@@ 0,0 1,86 @@
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%
% File:         PXNK:ieee-decls.sl for x86
% Description:  IEEE 754 specific declarations for PSL, 32 bit variant
% Author:       Rainer Sch�pf
% Created:      8 July 2018 
% Mode:         Lisp 
% Package:      nonkernel
% Status:       Open Source: BSD License
%
% (c) Copyright 1982, University of Utah
%
% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%
% Revisions:
%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

(define-constant ieeeshift (difference 12 bitsperword))
(define-constant signshift (difference 1 bitsperword))
(define-constant ieeebias 1023)
(define-constant ieeemask 2047)
(define-constant ieeemaxexp 1024)
(define-constant ieeeminexp -1023)

(ds floathiword (x) (floathighorder (inf x)))
(ds floatloword (x) (floatloworder (inf x)))

(ds ieeezerop(u)
    % ieee zero may have the sign bit set to indicate -0.0,
    % so shift the leftmost bit off the machine word before comparing with 0
    (and (weq (wshift (floathiword u) 1) 0)
	 (weq (floatloword u) 0)))

(ds ieeemant (f)
   ((lambda (lf)
       (lor
          (lshift
             (wor
                (wshift (wand (floathiword f) 16#fffff) 16#6)
                (wshift lf (minus 16#1a)))
             16#1a)
          (wand (lshift (minus 16#1) (minus 16#6)) lf)))
      (floatloword f)))

(ds ieeeexpt(u)
    (wdifference (wand ieeemask 
		       (wshift (floathiword u) ieeeshift))
		 ieeebias))

(ds ieeesign (u) (wshift (floathiword u) signshift))

(ds floatequal (u v)
    (and
     (weq (floathighorder (fltinf u))
	  (floathighorder (fltinf v)))
     (weq (floatloworder (fltinf u))
	  (floatloworder (fltinf v)))
     (not (and (weq (ieeeexpt u) ieeemaxexp) (wneq (ieeemant u) 0)))
     (not (and (weq (ieeeexpt v) ieeemaxexp) (wneq (ieeemant v) 0)))
     )
)