home *** CD-ROM | disk | FTP | other *** search
/ Source Code 1992 March / Source_Code_CD-ROM_Walnut_Creek_March_1992.iso / usenet / altsrcs / 2 / 2115 / sp.pl.part1
Encoding:
Text File  |  1990-12-28  |  23.3 KB  |  1,216 lines
  1. #!/usr/bin/perl
  2. # Scheme in Perl? (sp?)
  3. # Public domain. No strings attached.
  4.  
  5. ($version) = '$Revision: 2.6 $' =~ /: (\d+\.\d+)/;
  6.  
  7. #------
  8. #-- Basic data types.
  9. #------
  10.  
  11. # There are three places that know about data type representation:
  12. # 1. The &TYPE function.
  13. # 2. The basic functions for that type in this section.
  14. # 3. The equivalence routines (eq?, eqv?, and equal?).
  15. # Any change in representation needs to look at all these.
  16.  
  17. %TYPEname = ();
  18.  
  19. sub TYPES {
  20.     local($k);
  21.     for ($k = 0; $k < @_; $k += 2) {
  22.         @_[$k] = $k;
  23.         $TYPEname{@_[$k]} = @_[$k + 1];
  24.     }
  25. }
  26. &TYPES( $T_NONE,    'nothing',
  27.     $T_NIL,        'a null list',
  28.     $T_BOOLEAN,    'a boolean',
  29.     $T_NUMBER,    'a number',
  30.     $T_CHAR,    'a character',
  31.     $T_STRING,    'a string',
  32.     $T_PAIR,    'a pair',
  33.     $T_VECTOR,    'a vector',
  34.     $T_TABLE,    'a table',
  35.     $T_SYMBOL,    'a symbol',
  36.     $T_INPUT,    'an input port',
  37.     $T_OUTPUT,    'an output port',
  38.     $T_FORM,    'a special form',
  39.     $T_SUBR,    'a built-in procedure',
  40.     # Some derived types.  See &CHKtype.
  41.     $T_LIST,    'a list',
  42.     $T_PROCEDURE,    'a procedure',
  43.     $T_ANY,        'anything');
  44.  
  45. # Scheme object -> type.
  46. sub TYPE {
  47.     local($_) = @_;
  48.     if    (/^$/)    { $T_NIL; }
  49.     elsif (/^[01]/)    { $T_BOOLEAN; }
  50.     elsif (/^N/)    { $T_NUMBER; }
  51.     elsif (/^C/)    { $T_CHAR; }
  52.     elsif (/^Z'S/)    { $T_STRING; }
  53.     elsif (/^Z'P/)    { $T_PAIR; }
  54.     elsif (/^Z'V/)    { $T_VECTOR; }
  55.     elsif (/^Z'T/)    { $T_TABLE; }
  56.     elsif (/^Y/)    { $T_SYMBOL; }
  57.     elsif (/^FORM/)    { $T_FORM; }
  58.     elsif (/^SUBR/)    { $T_SUBR; }
  59.     elsif (/^Z'IP/)    { $T_INPUT; }
  60.     elsif (/^Z'OP/)    { $T_OUTPUT; }
  61.     else        { $T_NONE; }
  62. }
  63.  
  64. #-- More derived types.
  65.  
  66. # A closure is a vector that looks like
  67. #    #(CLOSURE env listarg nargs arg... code...)
  68. # See &lambda and &applyN.
  69. $CLOSURE = &Y('CLOSURE');
  70.  
  71. # A promise is a vector that looks like
  72. #    #(PROMISE env forced? value code...)
  73. # See &delay and &force.
  74. $PROMISE = &Y('PROMISE');
  75.  
  76. #-- Booleans.
  77.  
  78. # Scheme booleans and Perl booleans are designed to be equivalent.
  79.  
  80. $NIL = '';
  81. $TRUE = 1;
  82. $FALSE = 0;
  83.  
  84. #-- Numbers.
  85.  
  86. # Perl number -> Scheme number.
  87. sub N {
  88.     'N' . @_[0];
  89. }
  90.  
  91. # Scheme number -> Perl number.
  92. sub Nval {
  93.     &ERRbad_type(@_[0], $T_NUMBER) if @_[0] !~ /^N/;
  94.     $';
  95. }
  96.  
  97. #-- Characters.
  98.  
  99. # Perl character -> Scheme character.
  100. sub C {
  101.     'C' . @_[0];
  102. }
  103.  
  104. # Scheme character -> Perl character.
  105. sub Cval {
  106.     &ERRbad_type(@_[0], $T_CHAR) if @_[0] !~ /^C/;
  107.     $';
  108. }
  109.  
  110. #-- Strings.
  111. # Strings are encapsulated so that eqv? works properly.
  112.  
  113. # Perl string -> Scheme string.
  114. sub S {
  115.     local($sip) = @_;
  116.     local(*s) = local($z) = "Z'S" . ++$Z'S;
  117.     $s = $sip;
  118.     $z;
  119. }
  120.  
  121. # Scheme string -> Perl string.
  122. sub Sval {
  123.     &ERRbad_type(@_[0], $T_STRING) if @_[0] !~ /^Z'S/;
  124.     local(*s) = @_;
  125.     $s;
  126. }
  127.  
  128. # Scheme string <= start, length, new Perl string.
  129. sub Sset {
  130.     &ERRbad_type(@_[0], $T_STRING) if @_[0] !~ /^Z'S/;
  131.     local(@sip) = @_;
  132.     local(*s, $p, $l, $n) = @sip;
  133.     substr($s, $p, $l) = $n;
  134. }
  135.  
  136. #-- Pairs and lists.
  137.  
  138. # Perl vector (A, D) -> Scheme pair (A . D).
  139. sub P {
  140.     local(@sip) = @_;
  141.     local(*p) = local($z) = "Z'P" . ++$Z'P;
  142.     @p = @sip;
  143.     $z;
  144. }
  145.  
  146. # Scheme pair (A . D) -> Perl list (A, D).
  147. sub Pval {
  148.     &ERRbad_type(@_[0], $T_PAIR) if @_[0] !~ /^Z'P/;
  149.     local(*p) = @_;
  150.     @p;
  151. }
  152.  
  153. # Scheme pair (sexp0 . sexp1) <= index, new Scheme value.
  154. sub Pset {
  155.     &ERRbad_type(@_[0], $T_PAIR) if @_[0] !~ /^Z'P/;
  156.     local(@sip) = @_;
  157.     local(*p, $k, $n) = @sip;
  158.     @p[$k] = $n;
  159. }
  160.  
  161. # Perl vector -> Scheme list.
  162. sub L {
  163.     local(@v) = @_;
  164.     local($list) = $NIL;
  165.     $list = pop @v, pop @v if @v > 2 &&  @v[$#v - 1] eq '.';
  166.     $list = &P(pop @v, $list) while @v;
  167.     $list;
  168. }
  169.  
  170. # Scheme list -> Perl vector.  XXX Doesn't do improper or recursive lists.
  171. sub Lval {
  172.     local($list) = @_;
  173.     local($x, @v);
  174.     while ($list ne $NIL) {
  175.         ($x, $list) = &Pval($list);
  176.         push(@v, $x);
  177.     }
  178.     @v;
  179. }
  180.  
  181. #-- Vectors.
  182.  
  183. # Perl vector -> Scheme vector.
  184. sub V {
  185.     local(@sip) = @_;
  186.     local(*v) = local($z) = "Z'V" . ++$Z'V;
  187.     @v = @sip;
  188.     $z;
  189. }
  190.  
  191. # Scheme vector -> Perl vector.
  192. sub Vval {
  193.     &ERRbad_type(@_[0], $T_VECTOR) if @_[0] !~ /^Z'V/;
  194.     local(*v) = @_;
  195.     @v;
  196. }
  197.  
  198. # Scheme vector <= start, length, new Perl vector.
  199. sub Vset {
  200.     &ERRbad_type(@_[0], $T_VECTOR) if @_[0] !~ /^Z'V/;
  201.     local(@sip) = @_;
  202.     local(*v, $s, $l, @n) = @sip;
  203.     splice(@v, $s, $l, @n);
  204. }
  205.  
  206. #-- Tables.
  207.  
  208. # XXX Tables could use a "default value".
  209.  
  210. # -> Scheme table.
  211. sub T {
  212.     "Z'T" . ++$Z'T;
  213. }
  214.  
  215. # Scheme table, Scheme symbol -> Scheme value.
  216. sub Tval {
  217.     &ERRbad_type(@_[0], $T_TABLE) if @_[0] !~ /^Z'T/;
  218.     &ERRbad_type(@_[1], $T_SYMBOL) if @_[1] !~ /^Y/;
  219.     local(*t) = @_;
  220.     $t{$'};
  221. }
  222.  
  223. # Scheme table <= Perl string, new Scheme value.
  224. sub Tset {
  225.     &ERRbad_type(@_[0], $T_TABLE) if @_[0] !~ /^Z'T/;
  226.     &ERRbad_type(@_[1], $T_SYMBOL) if @_[1] !~ /^Y/;
  227.     local(@sip) = @_;
  228.     local(*t) = @sip;
  229.     $t{$'} = @sip[2];
  230. }
  231.  
  232. # Scheme table -> Perl vector of keys.
  233. sub Tkeys {
  234.     &ERRbad_type(@_[0], $T_TABLE) if @_[0] !~ /^Z'T/;
  235.     local(*t) = @_;
  236.     keys %t;
  237. }
  238.  
  239. #-- Symbols.
  240.  
  241. %OBLIST = ();
  242. $OBLIST = &REF("Z'Toblist", 'OBLIST');
  243.  
  244. # Perl string -> Scheme symbol.
  245. sub Y {
  246.     'Y' . @_[0];
  247. }
  248.  
  249. # Scheme symbol -> Perl string.
  250. sub Yname {
  251.     &ERRbad_type(@_[0], $T_SYMBOL) if @_[0] !~ /^Y/;
  252.     $';
  253. }
  254.  
  255. # Scheme symbol -> global Scheme value.
  256. sub Yval {
  257.     &ERRbad_type(@_[0], $T_SYMBOL) if @_[0] !~ /^Y/;
  258.     $OBLIST{$'};
  259. }
  260.  
  261. # Scheme symbol <= new global Scheme value.
  262. sub Yset {
  263.     &ERRbad_type(@_[0], $T_SYMBOL) if @_[0] !~ /^Y/;
  264.     $OBLIST{$'} = @_[1];
  265. }
  266.  
  267. # Perl string symbol name <= new global Scheme value.
  268. sub DEF {
  269.     $OBLIST{@_[0]} = @_[1];
  270. }
  271.  
  272. # Create an aliased object.
  273. sub REF {
  274.     local(@sip) = @_;
  275.     local($a, $b) = @sip;
  276.     eval "*$a = *$b" || die "ALIAS: $@.\n";
  277.     $a;
  278. }
  279.  
  280. &SUBR0('global-environment');
  281. sub global_environment {
  282.     $OBLIST;
  283. }
  284.  
  285. #-- Input and output ports.
  286.  
  287. %IPbuffer = ();
  288.  
  289. # Perl string filename -> Scheme input port.
  290. sub IP {
  291.     local($f) = @_;
  292.     local($z) = "Z'IP" . ++$Z'IP;
  293.     open($z, "< $f\0") || return $NIL;
  294.     $IPbuffer{$z} = '';
  295.     $z;
  296. }
  297.  
  298. # Scheme input port -> Perl filehandle.
  299. sub IPval {
  300.     &ERRbad_type(@_[0], $T_INPUT) if @_[0] !~ /^Z'IP/;
  301.     @_[0];
  302. }
  303.  
  304. # Scheme input port => Perl string.
  305. sub IPget {
  306.     &ERRbad_type(@_[0], $T_INPUT) if @_[0] !~ /^Z'IP/;
  307.     local($ip) = @_;
  308.     local($_) = $IPbuffer{$ip};
  309.     $_ ne '' ? ($IPbuffer{$ip} = '') : ($_ = <$ip>);
  310.     $_;
  311. }
  312.  
  313. # Like &IPget, but skip leading whitespace and comments.
  314. sub IPgetns {
  315.     &ERRbad_type(@_[0], $T_INPUT) if @_[0] !~ /^Z'IP/;
  316.     local($ip) = @_;
  317.     local($_) = $IPbuffer{$ip};
  318.     $_ ne '' ? ($IPbuffer{$ip} = '') : ($_ = <$ip>);
  319.     $_ = <$ip> while $_ ne '' && /^\s*;|^\s*$/;
  320.     s/^\s+//;
  321.     $_;
  322. }
  323.  
  324. # Scheme input port <= Perl string.
  325. sub IPput {
  326.     &ERRbad_type(@_[0], $T_INPUT) if @_[0] !~ /^Z'IP/;
  327.     $IPbuffer{@_[0]} .= @_[1];
  328. }
  329.  
  330. # Perl string filename -> Scheme output port.
  331. sub OP {
  332.     local($f) = @_;
  333.     local($z) = "Z'OP" . ++$Z'OP;
  334.     open($z, "> $f\0") || return $NIL;
  335.     $z;
  336. }
  337.  
  338. # Scheme output port -> Perl filehandle.
  339. sub OPval {
  340.     &ERRbad_type(@_[0], $T_OUTPUT) if @_[0] !~ /^Z'OP/;
  341.     @_[0];
  342. }
  343.  
  344. # Scheme output port <= Perl string.
  345. sub OPput {
  346.     &ERRbad_type(@_[0], $T_OUTPUT) if @_[0] !~ /^Z'OP/;
  347.     local(@sip) = @_;
  348.     local($fh) = shift @sip;
  349.     print $fh @sip;
  350. }
  351.  
  352. sub IOinit {
  353.     open($stdin  = "Z'IPstdin",  "<& STDIN");
  354.     open($stdout = "Z'OPstdout", ">& STDOUT");
  355.     open($stderr = "Z'OPstderr", ">& STDERR");
  356.     select($stderr); $| = 1;
  357.     $ttyin  = &IP('/dev/tty');
  358.     $ttyout = &OP('/dev/tty');
  359. }
  360.  
  361. sub IOshutdown {
  362.     close($stdin);
  363.     close($stdout);
  364.     close($stderr);
  365.     close($ttyin);
  366.     close($ttyout);
  367. }
  368.  
  369. &SUBR0('standard-input');  sub standard_input  { $stdin;  }
  370. &SUBR0('standard-output'); sub standard_output { $stdout; }
  371. &SUBR0('standard-error');  sub standard_error  { $stderr; }
  372. &SUBR0('terminal-input');  sub terminal_input  { $ttyin;  }
  373. &SUBR0('terminal-output'); sub terminal_output { $ttyout; }
  374.  
  375. #-- Special forms.
  376.  
  377. # Define Scheme special form <= name.
  378. sub FORM {
  379.     local($sub) = local($name) = @_[0];
  380.     $sub =~ tr/->?!*/_2PIX/;
  381.     &DEF($name, 'FORM' . $sub);
  382. }
  383.  
  384. # Scheme special form -> Perl subroutine name.
  385. sub FORMval {
  386.     &ERRbad_type(@_[0], $T_FORM) if @_[0] !~ /^FORM/;
  387.     $';
  388. }
  389.  
  390. #-- Builtin functions (subrs).
  391.  
  392. %SUBRmin = ();
  393. %SUBRmax = ();
  394. %SUBRtypes = ();
  395.  
  396. # Define Scheme builtin <= name, minargs, maxargs, type list.
  397. sub SUBR {
  398.     local(@sip) = @_;
  399.     local($name, $min, $max, @types) = @sip;
  400.     local($sub) = $name;
  401.     $sub =~ tr/->?!*/_2PIX/;
  402.     $SUBRmin{$sub} = $min;
  403.     $SUBRmax{$sub} = $max;
  404.     $SUBRtypes{$sub} = pack('L*', @types);
  405.     &DEF($name, 'SUBR' . $sub);
  406. }
  407.  
  408. # Scheme builtin function -> Perl sub name, minargs, maxargs, type list.
  409. sub SUBRval {
  410.     &ERRbad_type(@_[0], $T_SUBR) if @_[0] !~ /^SUBR/;
  411.     ($', $SUBRmin{$'}, $SUBRmax{$'}, unpack('L*', $SUBRtypes{$'}));
  412. }
  413.  
  414. # Some convenient aliases...
  415. sub SUBR0 { &SUBR(shift, 0, 0); }
  416. sub SUBR1 { &SUBR(shift, 1, 1, @_); }
  417. sub SUBR2 { &SUBR(shift, 2, 2, @_); }
  418. sub SUBR3 { &SUBR(shift, 3, 3, @_); }
  419. sub SUBRN { &SUBR(shift, 0, -1, @_); }
  420.  
  421. # A convenient macro...
  422. sub CMP_SUBR {
  423.     local(@sip) = @_;
  424.     local($name, $longname, $type, $acc, $cmp) = @sip;
  425.     local($s) = &SUBR($longname, 0, -1, $type);
  426.     &DEF($name, $s);
  427.     eval 'sub ' . (&SUBRval($s))[0] . ' {
  428.         local(@sip) = @_;
  429.         local($r) = 1;
  430.         for (; $r && @sip > 1; shift @sip) {
  431.             $r = '.$acc.'(@sip[0]) '.$cmp.' '.$acc.'(@sip[1]);
  432.         }
  433.         $r;
  434.     }';
  435. }
  436.  
  437. #-- Miscellany.
  438.  
  439. &SUBR0('*show-memory-use');
  440. sub Xshow_memory_use {
  441.     print $stderr 'memory use: s', $Z'S+0, ' p', $Z'P+0, ' v', $Z'V+0;
  442.     print $stderr ' t', $Z'T+0, ' ip', $Z'IP+0, ' op', $Z'OP+0;
  443.     print $stderr "\n";
  444. }
  445.  
  446. #------
  447. #-- Environments and frames.
  448. #------
  449.  
  450. # @ENVcurrent is a Perl vector that gets modified in place, for efficiency.
  451. # $ENVcache is a Scheme vector that's a copy of the current environment.
  452.  
  453. @ENVcurrent = ();
  454. $ENVcache = $FALSE;
  455. @ENVstack = ();
  456.  
  457. # Returns the current environment.
  458. sub ENVcurrent {
  459.     $ENVcache = &V(@ENVcurrent) if ! $ENVcache;
  460.     $ENVcache;
  461. }
  462.  
  463. # Push to a new environment.
  464. sub ENVpush {
  465.     local($new) = @_;
  466.     push(@ENVstack, $ENVcache || &V(@ENVcurrent));
  467.     @ENVcurrent = &Vval($new);
  468.     $ENVcache = $new;
  469. }
  470.  
  471. # Pop to the old environment.
  472. sub ENVpop {
  473.     $ENVcache = pop @ENVstack;
  474.     @ENVcurrent = &Vval($ENVcache);
  475. }
  476.  
  477. # Pop to the global environment.
  478. sub ENVreset {
  479.     @ENVstack = ();
  480.     $ENVcache = $FALSE;
  481.     @ENVcurrent = ();
  482. }
  483.  
  484. # Get a value from the current environment.
  485. sub ENVval {
  486.     local($sym) = @_;
  487.     local($x);
  488.     for $f (@ENVcurrent) {
  489.         return $x if defined($x = &Tval($f, $sym));
  490.     }
  491.     defined($x = &Yval($sym)) || &ERRunbound($sym);
  492.     $x;
  493. }
  494.  
  495. # Set a value in the current environment.
  496. sub ENVset {
  497.     local(@sip) = @_;
  498.     local($sym, $val) = @sip;
  499.     local($x);
  500.     for $f (@ENVcurrent) {
  501.         return &Tset($f, $sym, $val) if defined($x = &Tval($f, $sym));
  502.     }
  503.     return &Yset($sym, $val);
  504. }
  505.  
  506. # Push a new frame onto the current environment.
  507. sub ENVpush_frame {
  508.     $ENVcache = $FALSE;
  509.     unshift(@ENVcurrent, &T());
  510. }
  511.  
  512. # Remove the top frame from the current environment.
  513. sub ENVpop_frame {
  514.     $ENVcache = $FALSE;
  515.     shift @ENVcurrent;
  516. }
  517.  
  518. # Bind new values in the top frame of the current environment.
  519. sub ENVbind {
  520.     local(@syms) = @_;
  521.     local(@vals) = splice(@syms, @syms / 2, @syms / 2);
  522.     if (@ENVcurrent == 0) {
  523.         &Yset(shift @syms, shift @vals) while @syms;
  524.     } else {
  525.         local($t) = @ENVcurrent[0];
  526.         &Tset($t, shift @syms, shift @vals) while @syms;
  527.     }
  528. }
  529.  
  530. &DEF('current-environment', &SUBR0('ENVcurrent'));
  531.  
  532. #------
  533. #-- Error handling.
  534. #------
  535.  
  536. sub ERR {
  537.     print $stderr '** ', @_, "\n";
  538.     goto TOP;
  539. }
  540.  
  541. sub ERRbad_type {
  542.     local(@sip) = @_;
  543.     local($it, $what) = @sip;
  544.     $what = $TYPEname{$what} || "type $what";
  545.     print $stderr "** Internal type error, $it is not $what.\n";
  546.     goto TOP;
  547. }
  548.  
  549. sub ERRtype {
  550.     local(@sip) = @_;
  551.     local($it, $what, $where) = @_;
  552.     $what = $TYPEname{$what} || "type $what";
  553.     print $stderr "** Type error, ";
  554.     print $stderr "in $where, " if $where ne '';
  555.     &write($it);
  556.     print " is not $what.\n";
  557.     goto TOP;
  558. }
  559.  
  560. sub CHKtype {
  561.     local(@sip) = @_;
  562.     local($t0) = &TYPE(@sip[0]);
  563.     local($t1) = @sip[1];
  564.     &ERRtype(@_) unless
  565.         $t1 == $T_ANY ||
  566.         $t0 == $t1 ||
  567.         ($t1 == $T_LIST &&
  568.             ($t0 == $T_PAIR || $t0 == $T_NIL)) ||
  569.         ($t1 == $T_PROCEDURE &&
  570.             ($t0 == $T_SUBR || $t0 == $T_VECTOR))
  571.         ;
  572. }
  573.  
  574. sub ERRdomain {
  575.     local(@sip) = @_;
  576.     local($where) = shift @sip;
  577.     print $stderr "** Domain error, ";
  578.     print $stderr "in $where, " if $where ne '';
  579.     print $stderr @sip, "\n";
  580.     goto TOP;
  581. }
  582.  
  583. sub ERRunbound {
  584.     local($sym) = @_;
  585.     print $stderr '** Symbol ', &Yname($sym), " is unbound.\n";
  586.     goto TOP;
  587. }
  588.  
  589. #------
  590. #-- Booleans.
  591. #------
  592.  
  593. &DEF('t', $TRUE);
  594. &DEF('nil', $FALSE);
  595.  
  596. &SUBR1('boolean?');
  597. sub booleanP {
  598.     @_[0] eq $TRUE || @_[0] eq $FALSE;
  599. }
  600.  
  601. &SUBR1('not');
  602. sub not {
  603.     @_[0] ? $FALSE : $TRUE;
  604. }
  605.  
  606. #------
  607. #-- Equivalence.
  608. #------
  609.  
  610. # Perl ($x eq $y) means the same thing as Scheme (eq? x y).
  611.  
  612. &SUBR2('eq?');
  613. sub eqP {
  614.     @_[0] eq @_[1];
  615. }
  616.  
  617. &SUBR2('eqv?');
  618. sub eqvP {
  619.     return $TRUE if @_[0] eq @_[1];
  620.     local(@sip) = @_;
  621.     local($t) = &TYPE(@sip[0]);
  622.     if ($t != &TYPE(@sip[1])) {
  623.         $FALSE;
  624.     } elsif ($t == $T_NUMBER) {
  625.         &Nval(@sip[0]) == &Nval(@sip[1]);
  626.     } elsif ($t == $T_STRING) {
  627.         &Sval(@sip[0]) eq '' && &Sval(@sip[1]) eq '';
  628.     } elsif ($t == $T_VECTOR) {
  629.         &Vval(@sip[0]) == 0 && &Vval(@sip[1]) == 0;
  630.     } else {
  631.         $FALSE;
  632.     }
  633. }
  634.  
  635. # XXX Fails to terminate for recursive types.
  636. &SUBR2('equal?');
  637. sub equalP {
  638.     return $TRUE if @_[0] eq @_[1];
  639.     local(@sip) = @_;
  640.     local($t) = &TYPE(@sip[0]);
  641.     if ($t != &TYPE(@sip[1])) {
  642.         $FALSE;
  643.     } elsif ($t == $T_STRING) {
  644.         &Sval(@sip[0]) eq &Sval(@sip[1]);
  645.     } elsif ($t == $T_PAIR) {
  646.         local($a0, $d0) = &Pval(@sip[0]);
  647.         local($a1, $d1) = &Pval(@sip[1]);
  648.         &equalP($a0, $a1) && &equalP($d0, $d1);
  649.     } elsif ($t == $T_VECTOR) {
  650.         local(@v) = &Vval(@sip[0]);
  651.         local(@u) = &Vval(@sip[1]);
  652.         return $FALSE if @v != @u;
  653.         while (@v) {
  654.             return $FALSE if ! &equalP(shift @v, shift @u);
  655.         }
  656.         $TRUE;
  657.     } else {
  658.         &eqvP(@sip[0], @sip[1]);
  659.     }
  660. }
  661.  
  662. #------
  663. #-- Pairs and lists.
  664. #------
  665.  
  666. &SUBR1('pair?');
  667. sub pairP {
  668.     &TYPE(@_[0]) == $T_PAIR;
  669. }
  670.  
  671. &DEF('cons', &SUBR2('P'));
  672.  
  673. &SUBR1('car');
  674. sub car {
  675. # XXX Patchlevel 41 broke something; &car(&car($x)) doesn't work if this
  676. # XXX line is uncommented.
  677. #    &CHKtype(@_[0], $T_PAIR, 'car');
  678.     (&Pval(@_[0]))[0];
  679. }
  680.  
  681. &SUBR1('cdr', $T_PAIR);
  682. sub cdr {
  683. # XXX See comment for car.
  684. #    &CHKtype(@_[0], $T_PAIR, 'cdr');
  685.     (&Pval(@_[0]))[1];
  686. }
  687.  
  688. &SUBR2('set-car!', $T_PAIR);
  689. sub set_carI {
  690.     &Pset(@_[0], 0, @_[1]);
  691. }
  692.  
  693. &SUBR2('set-cdr!', $T_PAIR);
  694. sub set_cdrI {
  695.     &Pset(@_[0], 1, @_[1]);
  696. }
  697.  
  698. &SUBR1('caar'); sub caar { &car(&car(@_[0])); }
  699. &SUBR1('cadr'); sub cadr { &car(&cdr(@_[0])); }
  700. &SUBR1('cdar'); sub cdar { &cdr(&car(@_[0])); }
  701. &SUBR1('cddr'); sub cddr { &cdr(&cdr(@_[0])); }
  702.  
  703. # XXX caaar and friends.
  704.  
  705. &SUBR1('null?');
  706. sub nullP {
  707.     @_[0] eq $NIL;
  708. }
  709.  
  710. &DEF('list', &SUBRN('L'));
  711.  
  712. &SUBR1('length', $T_LIST);
  713. sub length {
  714.     local($p) = @_;
  715.     local($n) = 0;
  716.     $n += 1, $p = &cdr($p) while $p ne $NIL;
  717.     &N($n);
  718. }
  719.  
  720. &SUBRN('append');
  721. sub append {
  722.     local(@v) = @_;
  723.     local($p) = pop @v;
  724.     for $a (reverse @v) {
  725.         &CHKtype($a, $T_LIST, 'append');
  726.         for $b (reverse &Lval($a)) {
  727.             $p = &P($b, $p);
  728.         }
  729.     }
  730.     $p;
  731. }
  732.  
  733. &SUBR1('reverse', $T_LIST);
  734. sub reverse {
  735.     &L(reverse(&Lval(@_[0])));
  736. }
  737.  
  738. &SUBR2('list-tail', $T_LIST, $T_NUMBER);
  739. sub list_tail {
  740.     local(@sip) = @_;
  741.     local($p) = @sip[0];
  742.     local($k) = &Nval(@sip[1]);
  743.     $p = &cdr($p) while $k--;
  744.     $p;
  745. }
  746.  
  747. &SUBR2('list-ref', $T_LIST, $T_NUMBER);
  748. sub list_ref {
  749.     local(@sip) = @_;
  750.     local(@v) = &Lval(@sip[0]);
  751.     local($n) = &Nval(@sip[1]);
  752.     0 < $n && $n < @v ? @v[$n] : $NIL;    # XXX error?
  753. }
  754.  
  755. &SUBR1('last-pair', $T_LIST);
  756. sub last_pair {
  757.     local($p) = @_;
  758.     local($d);
  759.     $p = $d while &TYPE($d = &cdr($p)) == $T_PAIR;
  760.     $p;
  761. }
  762.  
  763. &SUBR2('memq', $T_ANY, $T_LIST);
  764. sub memq {
  765.     local(@sip) = @_;
  766.     local($x, $p) = @sip;
  767.     local($a, $d);
  768.     for (; $p ne $NIL; $p = $d) {    # XXX improper lists
  769.         ($a, $d) = &Pval($p);
  770.         return $p if $x eq $a;
  771.     }
  772.     return $FALSE;
  773. }
  774.  
  775. &SUBR2('memv', $T_ANY, $T_LIST);
  776. sub memv {
  777.     local(@sip) = @_;
  778.     local($x, $p) = @sip;
  779.     local($a, $d);
  780.     for (; $p ne $NIL; $p = $d) {    # XXX improper lists
  781.         ($a, $d) = &Pval($p);
  782.         return $p if &eqvP($x, $a);
  783.     }
  784.     return $FALSE;
  785. }
  786.  
  787. &SUBR2('member', $T_ANY, $T_LIST);
  788. sub member {
  789.     local(@sip) = @_;
  790.     local($x, $p) = @sip;
  791.     local($a, $d);
  792.     for (; $p ne $NIL; $p = $d) {    # XXX improper lists
  793.         ($a, $d) = &Pval($p);
  794.         return $p if &equalP($x, $a);
  795.     }
  796.     return $FALSE;
  797. }
  798.  
  799. &SUBR2('assq', $T_ANY, $T_LIST);
  800. sub assq {
  801.     local(@sip) = @_;
  802.     local($x, $p) = @_;
  803.     local($a);
  804.     while ($p ne $NIL) {    # XXX improper lists
  805.         ($a, $p) = &Pval($p);
  806.         return $a if $x eq &car($a);
  807.     }
  808.     return $FALSE;
  809. }
  810.  
  811. &SUBR2('assv', $T_ANY, $T_LIST);
  812. sub assv {
  813.     local(@sip) = @_;
  814.     local($x, $p) = @_;
  815.     local($a);
  816.     while ($p ne $NIL) {    # XXX improper lists
  817.         ($a, $p) = &Pval($p);
  818.         return $a if &eqvP($x, &car($a));
  819.     }
  820.     return $FALSE;
  821. }
  822.  
  823. &SUBR2('assoc', $T_ANY, $T_LIST);
  824. sub assoc {
  825.     local(@sip) = @_;
  826.     local($x, $p) = @_;
  827.     local($a);
  828.     while ($p ne $NIL) {    # XXX improper lists
  829.         ($a, $p) = &Pval($p);
  830.         return $a if &equalP($x, &car($a));
  831.     }
  832.     return $FALSE;
  833. }
  834.  
  835. #------
  836. #-- Symbols.
  837. #------
  838.  
  839. &SUBR1('symbol?');
  840. sub symbolP {
  841.     &TYPE(@_[0]) == $T_SYMBOL;
  842. }
  843.  
  844. &SUBR1('symbol->string', $T_SYMBOL);
  845. sub symbol_2string {
  846.     &S(&Yname(@_[0]));
  847. }
  848.  
  849. &SUBR1('string->symbol', $T_STRING);
  850. sub string_2symbol {
  851.     &Y(&Sval(@_[0]));
  852. }
  853.  
  854. #------
  855. #-- Numbers.
  856. #------
  857.  
  858. &SUBR1('number?');
  859. sub numberP {
  860.     &TYPE(@_[0]) == $T_NUMBER;
  861. }
  862.  
  863. &SUBR1('complex?');
  864. sub complexP {
  865.     &TYPE(@_[0]) == $T_NUMBER;
  866. }
  867.  
  868. &SUBR1('real?');
  869. sub realP {
  870.     &TYPE(@_[0]) == $T_NUMBER;
  871. }
  872.  
  873. &SUBR1('rational?');
  874. sub rationalP {
  875.     &integerP(@_[0]);
  876. }
  877.  
  878. &SUBR1('integer?');
  879. sub integerP {
  880.     return $FALSE if &TYPE(@_[0]) != $T_NUMBER;
  881.     local($n) = &Nval(@_[0]);
  882.     $n == int($n);
  883. }
  884.  
  885. &SUBR1('zero?', $T_NUMBER);
  886. sub zeroP {
  887.     &Nval(@_[0]) == 0;
  888. }
  889.  
  890. &SUBR1('positive?', $T_NUMBER);
  891. sub positiveP {
  892.     &Nval(@_[0]) > 0;
  893. }
  894.  
  895. &SUBR1('negative?', $T_NUMBER);
  896. sub negativeP {
  897.     &Nval(@_[0]) < 0;
  898. }
  899.  
  900. &SUBR1('odd?', $T_NUMBER);
  901. sub oddP {
  902.     &integerP(@_[0]) && (&Nval(@_[0]) & 1) == 1;
  903. }
  904.  
  905. &SUBR1('even?', $T_NUMBER);
  906. sub evenP {
  907.     &integerP(@_[0]) && (&Nval(@_[0]) & 1) == 0;
  908. }
  909.  
  910. &CMP_SUBR('=', 'number-eq?', $T_NUMBER, '&Nval', '==');
  911. &CMP_SUBR('<', 'number-lt?', $T_NUMBER, '&Nval', '<');
  912. &CMP_SUBR('>', 'number-gt?', $T_NUMBER, '&Nval', '>');
  913. &CMP_SUBR('<=', 'number-le?', $T_NUMBER, '&Nval', '<=');
  914. &CMP_SUBR('>=', 'number-ge?', $T_NUMBER, '&Nval', '>=');
  915.  
  916. &SUBR('max', 1, -1, $T_NUMBER);
  917. sub max {
  918.     local(@sip) = @_;
  919.     local($x) = &Nval(shift @sip);
  920.     for (; @sip; shift @sip) {
  921.         $x = &Nval(@sip[0]) if &Nval(@sip[0]) > $x;
  922.     }
  923.     &N($x);
  924. }
  925.  
  926. &SUBR('min', 1, -1, $T_NUMBER);
  927. sub min {
  928.     local(@sip) = @_;
  929.     local($x) = &Nval(shift @sip);
  930.     for (; @sip; shift @sip) {
  931.         $x = &Nval(@sip[0]) if &Nval(@sip[0]) < $x;
  932.     }
  933.     &N($x);
  934. }
  935.  
  936. &DEF('+', &SUBRN('add', $T_NUMBER));
  937. sub add {
  938.     local(@sip) = @_;
  939.     local($x) = 0;
  940.     $x += &Nval(shift @sip) while @sip;
  941.     &N($x);
  942. }
  943.  
  944. &DEF('-', &SUBR('subtract', 1, -1, $T_NUMBER));
  945. sub subtract {
  946.     local(@sip) = @_;
  947.     local($x) = &Nval(shift @sip);
  948.     $x = -$x if !@sip;
  949.     $x -= &Nval(shift @sip) while @sip;
  950.     &N($x);
  951. }
  952.  
  953. &DEF('*', &SUBRN('multiply', $T_NUMBER));
  954. sub multiply {
  955.     local(@sip) = @_;
  956.     local($x) = 1;
  957.     $x *= &Nval(shift @sip) while @sip;
  958.     &N($x);
  959. }
  960.  
  961. &DEF('/', &SUBR('divide', 1, -1, $T_NUMBER));
  962. sub divide {
  963.     local(@sip) = @_;
  964.     local($x) = &Nval(shift @sip);
  965.     if (@sip == 0) {
  966.         &ERRdomain('/', 'division by zero.') if $x == 0;
  967.         $x = 1 / $x;
  968.     } else {
  969.         local($y);
  970.         while (@sip) {
  971.             $y = &Nval(shift @sip);
  972.             &ERRdomain('/', 'division by zero.') if $y == 0;
  973.             $x /= $y;
  974.         }
  975.     }
  976.     &N($x);
  977. }
  978.  
  979. &DEF('1+', &SUBR1('inc', $T_NUMBER));
  980. sub inc {
  981.     &N(&Nval(@_[0]) + 1);
  982. }
  983.  
  984. &DEF('-1+', &SUBR1('dec', $T_NUMBER));
  985. sub dec {
  986.     &N(&Nval(@_[0]) - 1);
  987. }
  988.  
  989. &SUBR1('abs', $T_NUMBER);
  990. sub abs {
  991.     local($x) = &Nval(@_[0]);
  992.     &N($x > 0 ? $x : -$x);
  993. }
  994.  
  995. &SUBR2('quotient', $T_NUMBER, $T_NUMBER);
  996. sub quotient {
  997.     local(@sip) = @_;
  998.     local($y) = &Nval(@sip[1]);
  999.     &ERRdomain('quotient', 'division by zero.') if $y == 0;
  1000.     &N(int(&Nval(@sip[0]) / $y));
  1001. }
  1002.  
  1003. &SUBR2('remainder', $T_NUMBER, $T_NUMBER);
  1004. sub remainder {
  1005.     local(@sip) = @_;
  1006.     local($x) = &Nval(@sip[0]);
  1007.     local($y) = &Nval(@sip[1]);
  1008.     &ERRdomain('remainder', 'division by zero.') if $y == 0;
  1009.     &N($x - $y * int($x / $y));
  1010. }
  1011.  
  1012. &SUBR2('modulo', $T_NUMBER, $T_NUMBER);
  1013. sub modulo {
  1014.     local(@sip) = @_;
  1015.     local($x) = &Nval(@sip[0]);
  1016.     local($y) = &Nval(@sip[1]);
  1017.     &ERRdomain('modulo', 'division by zero.') if $y == 0;
  1018.     local($r) = $x - $y * int($x / $y);
  1019.     $r += $y if ($y < 0 && $r > 0) || ($y > 0 && $r < 0);
  1020.     &N($r);
  1021. }
  1022.  
  1023. # XXX SUBR numerator, denominator (rationals)
  1024.  
  1025. # XXX SUBR gcd, lcm
  1026.  
  1027. &SUBR1('floor', $T_NUMBER);
  1028. sub floor {
  1029.     local($n) = &Nval(@_[0]);
  1030.     if ($n == int($n)) {
  1031.         &N($n);
  1032.     } else {
  1033.         $n < 0 ? &N($n - 1) : &N($n);
  1034.     }
  1035. }
  1036.  
  1037. &SUBR1('ceiling', $T_NUMBER);
  1038. sub ceiling {
  1039.     local($n) = &Nval(@_[0]);
  1040.     if ($n == int($n)) {
  1041.         &N($n);
  1042.     } else {
  1043.         $n < 0 ? &N($n) : &N($n + 1);
  1044.     }
  1045. }
  1046.  
  1047. &SUBR1('truncate', $T_NUMBER);
  1048. sub truncate {
  1049.     &N(int(&Nval(@_[0])));
  1050. }
  1051.  
  1052. &SUBR1('round', $T_NUMBER);
  1053. sub round {
  1054.     local($n) = &Nval(@_[0]);
  1055.     if ($n + .5 == int($n + .5)) {
  1056.         if ($n < 0) {
  1057.             1 & (-$n - .5) ? &N($n - .5) : &N($n + .5);
  1058.         } else {
  1059.             1 & ($n + .5) ? &N($n - .5) : &N($n + .5);
  1060.         }
  1061.     } else {
  1062.         $n < 0 ? &N(int($n - .5)) : &N(int($n + .5));
  1063.     }
  1064. }
  1065.  
  1066. # XXX SUBR rationalize
  1067.  
  1068. &SUBR1('exp', $T_NUMBER);
  1069. sub exp {
  1070.     &N(exp(&Nval(@_[0])));
  1071. }
  1072.  
  1073. &SUBR1('log', $T_NUMBER);
  1074. sub log {
  1075.     local($x) = &Nval(@_[0]);
  1076.     &ERRdomain('log', 'singularity at zero.') if $x == 0;
  1077.     &N(log($x));
  1078. }
  1079.  
  1080. &SUBR1('sin', $T_NUMBER);
  1081. sub sin {
  1082.     &N(sin(&Nval(@_[0])));
  1083. }
  1084.  
  1085. &SUBR1('cos', $T_NUMBER);
  1086. sub cos {
  1087.     &N(cos(&Nval(@_[0])));
  1088. }
  1089.  
  1090. &SUBR1('tan', $T_NUMBER);
  1091. sub tan {
  1092.     local($x) = &Nval(@_[0]);
  1093.     &N(sin($x)/cos($x));    # XXX domain error
  1094. }
  1095.  
  1096. &SUBR1('asin', $T_NUMBER);
  1097. sub asin {
  1098.     local($x) = &Nval(@_[0]);
  1099.     &ERRdomain('asin', $x, ' is not in [-1, 1].') if $x < -1 || $x > 1;
  1100.     &N(atan2($x, sqrt(1 - $x * $x)));
  1101. }
  1102.  
  1103. &SUBR1('acos', $T_NUMBER);
  1104. sub acos {
  1105.     local($x) = &Nval(@_[0]);
  1106.     &ERRdomain('acos', $x, ' is not in [-1, 1].') if $x < -1 || $x > 1;
  1107.     &N(atan2(sqrt(1 - $x * $x), $x));
  1108. }
  1109.  
  1110. &SUBR('atan', 1, 2, $T_NUMBER, $T_NUMBER);
  1111. sub atan {
  1112.     local(@sip) = @_;
  1113.     local($x) = &Nval(@_[0]);
  1114.     local($y) = @_ > 1 ? &Nval(@_[1]) : 1;
  1115.     &N(atan2($x, $y));    # XXX domain error
  1116. }
  1117.  
  1118. &SUBR1('sqrt', $T_NUMBER);
  1119. sub sqrt {
  1120.     &N(sqrt(&Nval(@_[0])));    # XXX domain error
  1121. }
  1122.  
  1123. &SUBR2('expt', $T_NUMBER, $T_NUMBER);
  1124. sub expt {
  1125.     local(@sip) = @_;
  1126.     local($x) = &Nval(@_[0]);
  1127.     local($y) = &Nval(@_[1]);
  1128.     if ($x == 0 && $y == 0) {
  1129.         &N(1);    # required in R3RS.
  1130.     } else {
  1131.         &N($x ** $y);    # XXX domain error.
  1132.     }
  1133. }
  1134.  
  1135. # XXX SUBR make-rectangular, make-polar, real-part, imag-part,
  1136. # XXX SUBR magnitude, angle
  1137. # XXX SUBR exact->inexact, inexact->exact
  1138.  
  1139. # XXX SUBR number->string, string->number
  1140.  
  1141. #------
  1142. #-- Characters.
  1143. #------
  1144.  
  1145. &SUBR1('char?');
  1146. sub charP {
  1147.     &TYPE(@_[0]) == $T_CHAR;
  1148. }
  1149.  
  1150. &CMP_SUBR('char=?', 'char-eq?', $T_CHAR, '&Cval', 'eq');
  1151. &CMP_SUBR('char<?', 'char-lt?', $T_CHAR, '&Cval', 'lt');
  1152. &CMP_SUBR('char>?', 'char-gt?', $T_CHAR, '&Cval', 'gt');
  1153. &CMP_SUBR('char<=?', 'char-le?', $T_CHAR, '&Cval', 'le');
  1154. &CMP_SUBR('char>=?', 'char-ge?', $T_CHAR, '&Cval', 'ge');
  1155.  
  1156. sub ciCval {
  1157.     local($_) = &Cval(@_[0]);
  1158.     tr/A-Z/a-z/;
  1159.     $_;
  1160. }
  1161. &CMP_SUBR('char-ci=?', 'char-ci-eq?', $T_CHAR, '&ciCval', 'eq');
  1162. &CMP_SUBR('char-ci<?', 'char-ci-lt?', $T_CHAR, '&ciCval', 'lt');
  1163. &CMP_SUBR('char-ci>?', 'char-ci-gt?', $T_CHAR, '&ciCval', 'gt');
  1164. &CMP_SUBR('char-ci<=?', 'char-ci-le?', $T_CHAR, '&ciCval', 'le');
  1165. &CMP_SUBR('char-ci>=?', 'char-ci-ge?', $T_CHAR, '&ciCval', 'ge');
  1166.  
  1167. &SUBR1('char-alphabetic?', $T_CHAR);
  1168. sub char_alphabeticP {
  1169.     &Cval(@_[0]) =~ /[a-zA-Z]/ ? $TRUE : $FALSE;
  1170. }
  1171.  
  1172. &SUBR1('char-numeric?', $T_CHAR);
  1173. sub char_numericP {
  1174.     &Cval(@_[0]) =~ /[0-9]/ ? $TRUE : $FALSE;
  1175. }
  1176.  
  1177. &SUBR1('char-whitespace?', $T_CHAR);
  1178. sub char_whitespaceP {
  1179.     &Cval(@_[0]) =~ /\s/ ? $TRUE : $FALSE;
  1180. }
  1181.  
  1182. &SUBR1('char-upper-case?', $T_CHAR);
  1183. sub char_upper_caseP {
  1184.     &Cval(@_[0]) =~ /[A-Z]/ ? $TRUE : $FALSE;
  1185. }
  1186.  
  1187. &SUBR1('char-lower-case?', $T_CHAR);
  1188. sub char_lower_caseP {
  1189.     &Cval(@_[0]) =~ /[a-z]/ ? $TRUE : $FALSE;
  1190. }
  1191.  
  1192. &SUBR1('char->integer', $T_CHAR);
  1193. sub char_2integer {
  1194.     &N(ord(&Cval(@_[0])));
  1195. }
  1196.  
  1197. &SUBR1('integer->char', $T_NUMBER);
  1198. sub integer_2char {
  1199.     &C(sprintf("%c", &Nval(@_[0])));
  1200. }
  1201.  
  1202. &SUBR1('char-upcase', $T_CHAR);
  1203. sub char_upcase {
  1204.     local($c) = &Cval(@_[0]);
  1205.     $c =~ tr/a-z/A-Z/;
  1206.     &C($c);
  1207. }
  1208.  
  1209. &SUBR1('char-downcase', $T_CHAR);
  1210. sub char_downcase {
  1211.     local($c) = &Cval(@_[0]);
  1212.     $c =~ tr/A-Z/a-z/;
  1213.     &C($c);
  1214. }
  1215.  
  1216.