home *** CD-ROM | disk | FTP | other *** search
/ Source Code 1992 March / Source_Code_CD-ROM_Walnut_Creek_March_1992.iso / usenet / altsrcs / 2 / 2116 / sp.pl.part2
Encoding:
Text File  |  1990-12-28  |  20.3 KB  |  1,107 lines
  1. #------
  2. #-- Strings.
  3. #------
  4.  
  5. &SUBR1('string?');
  6. sub stringP {
  7.     &TYPE(@_[0]) == $T_STRING;
  8. }
  9.  
  10. &SUBR('make-string', 1, 2, $T_NUMBER, $T_CHAR);
  11. sub make_string {
  12.     local(@sip) = @_;
  13.     local($c) = @sip > 1 ? &Cval(@sip[1]) : '.';
  14.     &S($c x &Nval(@sip[0]));
  15. }
  16.  
  17. &SUBR1('string-length', $T_STRING);
  18. sub string_length {
  19.     &N(length(&Sval(@_[0])));
  20. }
  21.  
  22. &SUBR2('string-ref', $T_STRING, $T_NUMBER);
  23. sub string_ref {
  24.     &C(substr(&Sval(@_[0]), &Nval(@_[1]), 1));
  25. }
  26.  
  27. &SUBR3('string-set!', $T_STRING, $T_NUMBER, $T_CHAR);
  28. sub string_setI {
  29.     &Sset(@_[0], &Nval(@_[1]), 1, &Cval(@_[2]));    # XXX domain error.
  30.     $TRUE;
  31. }
  32.  
  33. &CMP_SUBR('string=?', 'string-eq?', $T_STRING, '&Sval', 'eq');
  34. &CMP_SUBR('string<?', 'string-lt?', $T_STRING, '&Sval', 'lt');
  35. &CMP_SUBR('string>?', 'string-gt?', $T_STRING, '&Sval', 'gt');
  36. &CMP_SUBR('string<=?', 'string-le?', $T_STRING, '&Sval', 'le');
  37. &CMP_SUBR('string>=?', 'string-ge?', $T_STRING, '&Sval', 'ge');
  38.  
  39. sub ciSval {
  40.     local($_) = &Sval(@_[0]);
  41.     tr/A-Z/a-z/;
  42.     $_;
  43. }
  44. &CMP_SUBR('string-ci=?', 'string-ci-eq?', $T_STRING, '&ciSval', 'eq');
  45. &CMP_SUBR('string-ci<?', 'string-ci-lt?', $T_STRING, '&ciSval', 'lt');
  46. &CMP_SUBR('string-ci>?', 'string-ci-gt?', $T_STRING, '&ciSval', 'gt');
  47. &CMP_SUBR('string-ci<=?', 'string-ci-le?', $T_STRING, '&ciSval', 'le');
  48. &CMP_SUBR('string-ci>=?', 'string-ci-ge?', $T_STRING, '&ciSval', 'ge');
  49.  
  50. &SUBR3('substring', $T_STRING, $T_NUMBER, $T_NUMBER);
  51. sub substring {
  52.     local(@sip) = @_;
  53.     local($p) = &Nval(@sip[1]);
  54.     &S(substr(&Sval(@sip[0]), $p, &Nval(@sip[2]) - $p));
  55. }
  56.  
  57. &SUBRN('string-append', $T_STRING);
  58. sub string_append {
  59.     local(@sip) = @_;
  60.     local($s) = '';
  61.     $s .= &Sval(shift @sip) while @sip;
  62.     &S($s);
  63. }
  64.  
  65. &SUBR1('string->list', $T_STRING);
  66. sub string_2list {
  67.     local(@sip) = @_;
  68.     local($p) = $NIL;
  69.     for $c (reverse split(//, &Sval(@sip[0]))) {
  70.         $p = &P(&C($c), $p);
  71.     }
  72.     $p;
  73. }
  74.  
  75. &SUBR1('list->string', $T_LIST);
  76. sub list_2string {
  77.     local($p) = @_;
  78.     local($s) = '';
  79.     local($a);
  80.     while ($p ne $NIL) {    # XXX improper lists.
  81.         ($a, $p) = &Pval($p);
  82.         &CHKtype($a, $T_CHAR, 'list->string');
  83.         $s = $s . &Cval($a);
  84.     }
  85.     &S($s);
  86. }
  87.  
  88. &SUBR1('string-copy', $T_STRING);
  89. sub string_copy {
  90.     &S(&Sval(@_[0]));
  91. }
  92.  
  93. &SUBR2('string-fill!', $T_STRING, $T_CHAR);
  94. sub string_fillI {
  95.     local(@sip) = @_;
  96.     local($s, $c) = @sip;
  97.     local($len) = length(&Sval($s));
  98.     &Sset($s, 0, $len, &Cval($c) x $len);
  99.     $TRUE;
  100. }
  101.  
  102. #------
  103. #-- Vectors.
  104. #------
  105.  
  106. &SUBR1('vector?');
  107. sub vectorP {
  108.     &TYPE(@_[0]) == $T_VECTOR;
  109. }
  110.  
  111. &SUBR('make-vector', 1, 2, $T_NUMBER);
  112. sub make_vector {
  113.     local(@sip) = @_;
  114.     local($n) = &Nval(@sip[0]);
  115.     local($x) = @sip > 1 ? @sip[1] : $FALSE;
  116.     local(@v);
  117.     $#v = $n - 1;
  118.     for $k (@v) { $k = $x; }
  119.     &V(@v);
  120. }
  121.  
  122. &DEF('vector', &SUBRN('V'));
  123.  
  124. &SUBR1('vector-length', $T_VECTOR);
  125. sub vector_length {
  126.     &N(&Vval(@_[0]) + 0);
  127. }
  128.  
  129. &SUBR2('vector-ref', $T_VECTOR, $T_NUMBER);
  130. sub vector_ref {
  131.     (&Vval(@_[0]))[&Nval(@_[1])];
  132. }
  133.  
  134. &SUBR3('vector-set!', $T_VECTOR, $T_NUMBER, $T_ANY);
  135. sub vector_setI {
  136.     &Vset(@_[0], &Nval(@_[1]), 1, @_[2]);
  137. }
  138.  
  139. &SUBR1('vector-copy', $T_VECTOR);
  140. sub vector_copy {
  141.     &V(&Vval(@_[0]));
  142. }
  143.  
  144. &SUBR1('vector->list', $T_VECTOR);
  145. sub vector_2list {
  146.     &L(&Vval(@_[0]));
  147. }
  148.  
  149. &SUBR1('list->vector', $T_LIST);
  150. sub list_2vector {
  151.     &V(&Lval(@_[0]));    # XXX improper lists.
  152. }
  153.  
  154. #------
  155. #-- Tables.  (extension)
  156. #------
  157.  
  158. &SUBR1('table?');
  159. sub tableP {
  160.     &TYPE(@_[0]) == $T_TABLE;
  161. }
  162.  
  163. &DEF('make-table', &SUBR0('T'));
  164.  
  165. &SUBR3('table-set!', $T_TABLE, $T_SYMBOL);
  166. sub table_setI {
  167.     &Tset(@_[0], @_[1], @_[2]);
  168.     $TRUE;
  169. }
  170.  
  171. &SUBR2('table-ref', $T_TABLE, $T_SYMBOL);
  172. sub table_ref {
  173.     &Tval(@_[0], @_[1]);
  174. }
  175.  
  176. &SUBR1('table-keys', $T_TABLE);
  177. sub table_keys {
  178.     local(@v) = &Tkeys(@_[0]);
  179.     for $k (@v) {
  180.         $k = &Y($k);
  181.     }
  182.     &V(@v);
  183. }
  184.  
  185. #------
  186. #-- Syntactic keywords, special forms.
  187. #------
  188.  
  189. $ARROW = &Y('=>');
  190. $ELSE = &Y('else');
  191. $QUOTE = &Y('quote');
  192. $QUASIQUOTE = &Y('quasiquote');
  193. $UNQUOTE = &Y('unquote');
  194. $UNQUOTE_SPLICING = &Y('unquote-splicing');
  195.  
  196. &FORM('quote');
  197. sub quote {
  198.     @_[0];
  199. }
  200.  
  201. # XXX wrote quasiquote in a delirium.  it may not work correctly.
  202. &FORM('quasiquote');
  203. sub quasiquote {
  204.     &QQ(@_[0], 0);
  205. }
  206.  
  207. sub QQ {
  208.     local(@sip) = @_;
  209.     local($it, $n) = @sip;
  210.     local($t) = &TYPE($it);
  211.     if ($t == $T_VECTOR) {
  212.         return &QQvector($it, $n);
  213.     } elsif ($t == $T_PAIR) {
  214.         return &QQlist($it, $n);
  215.     } else {
  216.         return $it;
  217.     }
  218. }
  219.  
  220. sub QQvector {
  221.     local(@sip) = @_;
  222.     local($it, $n) = @sip;
  223.     return &list_2vector(&QQlist(&vector_2list($it), $n));
  224. }
  225.  
  226. sub QQlist {
  227.     local(@sip) = @_;
  228.     local($it, $n) = @sip;
  229.     local($a, $d) = &Pval($it);
  230.     if ($a eq $QUASIQUOTE) {
  231.         return &L($QUASIQUOTE, &QQ(&car($d), $n + 1));
  232.     } elsif ($a eq $UNQUOTE) {
  233.         return $n == 0
  234.             ? &eval(&car($d))
  235.             : &L($UNQUOTE, &QQ(&car($d), $n - 1));
  236.     }
  237.  
  238.     if (&pairP($a) && &car($a) eq $UNQUOTE_SPLICING) {
  239.         $a = ($n == 0)
  240.             ? &eval(&cadr($a))
  241.             : &L($UNQUOTE_SPLICING, &QQ(&cadr($a), $n - 1));
  242.     } else {
  243.         $a = &L(&QQ($a, $n));
  244.     }
  245.     if ($d ne $NIL) {
  246.         return &append($a, &QQ($d, $n));
  247.     } else {
  248.         return $a;
  249.     }
  250. }
  251.  
  252. &FORM('delay');
  253. sub delay {
  254.     &V($PROMISE, $NIL, $NIL, &ENVcurrent(), @_);
  255. }
  256.  
  257. &FORM('lambda');
  258. sub lambda {
  259.     local(@code) = @_;
  260.     local($args) = shift @code;
  261.     local($a, @syms);
  262.     while (&pairP($args)) {
  263.         ($a, $args) = &Pval($args);
  264.         &CHKtype($a, $T_SYMBOL, 'lambda');
  265.         push(@syms, $a);
  266.     }
  267.     &CHKtype($args, $T_SYMBOL, 'lambda') if $args ne $NIL;
  268.     &V($CLOSURE, &ENVcurrent(), $args, &N(@syms + 0), @syms, @code);
  269. }
  270.  
  271. # XXX named let form
  272. &FORM('let');
  273. sub let {
  274.     local(@code) = @_;
  275.     local(@bindings) = &Lval(shift @code);
  276.     local(@syms, @vals);
  277.     for $x (@bindings) {
  278.         push(@syms, &car($x));
  279.         push(@vals, &eval(&cadr($x)));
  280.     }
  281.     &ENVpush_frame();
  282.     &ENVbind(@syms, @vals);
  283.     local($x) = &begin(@code);
  284.     &ENVpop_frame();
  285.     $x;
  286. }
  287.  
  288. &FORM('let*');
  289. sub letX {
  290.     local(@code) = @_;
  291.     local(@bindings) = &Lval(shift @code);
  292.     local($x);
  293.     &ENVpush(&ENVcurrent());
  294.     for $b (@bindings) {
  295.         $x = &eval(&cadr($b));
  296.         &ENVpush_frame();
  297.         &ENVbind(&car($b), $x);
  298.     }
  299.     $x = &begin(@code);
  300.     &ENVpop();
  301.     $x;
  302. }
  303.  
  304. &FORM('letrec');
  305. sub letrec {
  306.     local(@code) = @_;
  307.     local(@bindings) = &Lval(shift @code);
  308.     local($x, @syms, @vals);
  309.     for $x (@bindings) {
  310.         push(@syms, &car($x));
  311.     }
  312.     &ENVpush_frame();
  313.     &ENVbind(@syms, @syms);
  314.     for $x (@bindings) {
  315.         push(@vals, &eval(&cadr($x)));
  316.     }
  317.     &ENVbind(@syms, @vals);
  318.     local($x) = &begin(@code);
  319.     &ENVpop_frame();
  320.     $x;
  321. }
  322.  
  323. &FORM('do');
  324. sub do {
  325.     local(@code) = @_;
  326.     local($bindings) = shift @code;
  327.     local($y, $v, $n, @syms, @vals, @nexts);
  328.     for $x (&Lval($bindings)) {
  329.         ($y, $v, $n) = &Lval($x);
  330.         if (defined $n) {
  331.             unshift(@syms, $y);
  332.             unshift(@vals, &eval($v));
  333.             unshift(@nexts, $n);
  334.         } else {
  335.             push(@syms, $y);
  336.             push(@vals, &eval($v));
  337.         }
  338.     }
  339.     &ENVpush_frame();
  340.     &ENVbind(@syms, @vals);
  341.  
  342.     $#syms = $#nexts;
  343.  
  344.     local($test, @exit) = &Lval(shift @code);
  345.  
  346.     while (!&eval($test)) {
  347.         &begin(@code);
  348.     } continue {
  349.         @vals = ();
  350.         for $x (@nexts) {
  351.             push(@vals, &eval($x));
  352.         }
  353.         &ENVbind(@syms, @vals);
  354.     }
  355.     local($x) = &begin(@exit);
  356.     &ENVpop_frame();
  357.     $x;
  358. }
  359.  
  360. &FORM('set!');
  361. sub setI {
  362.     &CHKtype(@_[0], $T_SYMBOL, 'set!');
  363.     # XXX argcount, syntax error.
  364.     # XXX error if unbound?
  365.     &ENVset(@_[0], &eval(@_[1]));
  366.     $TRUE;
  367. }
  368.  
  369. &FORM('define');
  370. sub define {
  371.     local(@sip) = @_;
  372.     local($sym) = shift @sip;
  373.     local($t) = &TYPE($sym);
  374.     if ($t == $T_SYMBOL) {
  375.         &ENVbind($sym, &eval(@sip[0]));
  376.     } elsif ($t == $T_PAIR) {
  377.         local($args);
  378.         ($sym, $args) = &Pval($sym);
  379.         &CHKtype($sym, $T_SYMBOL, 'define');
  380.         &ENVbind($sym, &lambda($args, @sip));
  381.     } else {
  382.         &ERRtype($sym, 'a symbol or a pair', 'define');
  383.     }
  384.     $TRUE;
  385. }
  386.  
  387. &FORM('begin');
  388. sub begin {
  389.     local(@sip) = @_;
  390.     local($x) = $NIL;
  391.     $x = &eval(shift @sip) while @sip;
  392.     $x;
  393. }
  394.  
  395. &FORM('and');
  396. sub and {
  397.     local(@sip) = @_;
  398.     local($x) = $TRUE;
  399.     $x = &eval(shift @sip) while $x && @sip;
  400.     $x;
  401. }
  402.  
  403. &FORM('or');
  404. sub or {
  405.     local(@sip) = @_;
  406.     local($x) = $FALSE;
  407.     $x = &eval(shift @sip) while !$x && @sip;
  408.     $x;
  409. }
  410.  
  411. &FORM('if');
  412. sub if {
  413.     # XXX argcount, syntax error.
  414.     if (&eval(@_[0])) {
  415.         &eval(@_[1]);
  416.     } elsif (@_[2] ne '') {
  417.         &eval(@_[2]);
  418.     } else {
  419.         $NIL;
  420.     }
  421. }
  422.  
  423. &FORM('cond');
  424. sub cond {
  425.     local(@sip) = @_;
  426.     local($a, $d, $x);
  427.     for $it (@sip) {
  428.         &CHKtype($it, $T_PAIR, 'cond');
  429.         ($a, $d) = &Pval($it);
  430.         if ($a eq $ELSE || ($x = &eval($a))) {
  431.             &CHKtype($it, $T_PAIR, 'cond');
  432.             local(@v) = &Lval($d);
  433.             if (@v[0] eq $ARROW) {
  434.                 # XXX syntax error, @v > 2;
  435.                 return &applyN(&eval(@v[1]), $x);
  436.             } else {
  437.                 return &begin(@v);
  438.             }
  439.         }
  440.     }
  441.     return $NIL;
  442. }
  443.  
  444. &FORM('case');
  445. sub case {
  446.     local(@sip) = @_;
  447.     local($x) = &eval(shift @sip);
  448.     local($a, $d);
  449.     for $it (@sip) {
  450.         &CHKtype($it, $T_PAIR, 'case');
  451.         ($a, $d) = &Pval($it);
  452.         if ($a eq $ELSE || &memv($x, $a)) {    # XXX pair? $a
  453.             &CHKtype($d, $T_PAIR, 'case');
  454.             return &begin(&Lval($d));
  455.         }
  456.     }
  457.     return $NIL;
  458. }
  459.  
  460. &FORM('*time-execution');
  461. sub Xtime_execution {
  462.     local(@code) = @_;
  463.     local($x);
  464.     local($u0, $s0, $cu0, $cs0, $t0);
  465.     local($u1, $s1, $cu1, $cs1, $t1);
  466.     $t0 = time;
  467.     ($u0, $s0, $cu0, $cs0) = times;
  468.     $x = &begin(@code);
  469.     ($u1, $s1, $cu1, $cs1) = times;
  470.     $t1 = time;
  471.     printf $stderr "\ntimes: %.3f user, %.3f system, %d:%02d real.\n",
  472.         $u1 - $u0 + $cu1 - $cu1,
  473.         $s1 - $s0 + $cs1 - $cu1,
  474.         ($t1 - $t0) / 60, ($t1 - $t0) % 60;
  475. }
  476.  
  477. #------
  478. #-- Input and output ports.
  479. #------
  480.  
  481. @IPstack = ();
  482. @OPstack = ();
  483.  
  484. $IPcurrent = $stdin;
  485. $OPcurrent = $stdout;
  486.  
  487. # Restore I/O to a sane state.
  488. sub IOreset {
  489.     @IPstack = ();
  490.     @OPstack = ();
  491.     $IPcurrent = $stdin;
  492.     $OPcurrent = $stdout;
  493.     select(&OPval($stdout));
  494.     $| = 1;
  495. }
  496.  
  497. &SUBR1('input-port?');
  498. sub input_portP {
  499.     &TYPE(@_[0]) == $T_INPUT;
  500. }
  501.  
  502. &SUBR1('output-port?');
  503. sub output_portP {
  504.     &TYPE(@_[0]) == $T_OUTPUT;
  505. }
  506.  
  507. &SUBR0('current-input-port');
  508. sub current_input_port {
  509.     $IPcurrent;
  510. }
  511.  
  512. &SUBR0('current-output-port');
  513. sub current_output_port {
  514.     $OPcurrent;
  515. }
  516.  
  517. &SUBR2('with-input-from-file', $T_STRING, $T_PROCEDURE);
  518. sub with_input_from_file {
  519.     local(@sip) = @_;
  520.     local($f) = &IP(&Sval(@sip[0]));
  521.     return $NIL if !$f;    # XXX open error
  522.  
  523.     push(@IPstack, $IPcurrent);
  524.     $IPcurrent = $f;
  525.     local($x) = &applyN(@sip[1]);
  526.     $IPcurrent = pop @IPstack;
  527.     close(&IPval($f));
  528.     $x;
  529. }
  530.  
  531. &SUBR2('with-output-to-file', $T_STRING, $T_PROCEDURE);
  532. sub with_output_to_file {
  533.     local(@sip) = @_;
  534.     local($f) = &OP(&Sval(@sip[0]));
  535.     return $NIL if !$f;    # XXX open error.
  536.  
  537.     push(@OPstack, $OPcurrent);
  538.     $OPcurrent = $f;
  539.     local($x) = &applyN(@sip[1]);
  540.     $OPcurrent = pop @OPstack;
  541.     close(&OPval($f));
  542.     $x;
  543. }
  544.  
  545. &SUBR1('open-input-file', $T_STRING);
  546. sub open_input_file {
  547.     &IP(&Sval(@_[0]));    # XXX open error.
  548. }
  549.  
  550. &SUBR1('open-output-file', $T_STRING);
  551. sub open_output_file {
  552.     &OP(&Sval(@_[0]));    # XXX open error.
  553. }
  554.  
  555. &SUBR1('close-input-port', $T_INPUT);
  556. sub close_input_port {
  557.     close(&IPval(@_[0]));    # XXX should destroy port.
  558.     &IPget(@_[0]);    # flush the input buffer.
  559.     $TRUE;
  560. }
  561.  
  562. &SUBR1('close-output-port', $T_OUTPUT);
  563. sub close_output_port {
  564.     close(&OPval(@_[0]));    # XXX should destroy port.
  565.     $TRUE;
  566. }
  567.  
  568. #------
  569. #-- Input.
  570. #------
  571.  
  572. $EOF = &Y('#EOF');    # eof object.
  573.  
  574. &SUBR1('eof-object?');
  575. sub eof_objectP {
  576.     @_[0] eq $EOF;
  577. }
  578.  
  579. &SUBR('read-char', 0, 1, $T_INPUT);
  580. sub read_char {
  581.     local($ip) = @_ ? @_ : $IPcurrent;
  582.     local($_) = &IPget($ip);
  583.     return $EOF if $_ eq '';
  584.     local($c) = substr($_, 0, 1);
  585.     &IPput($ip, substr($_, 1, length - 1));
  586.     &C($c);
  587. }
  588.  
  589. &SUBR('char-ready?', 0, 1, $T_INPUT);
  590. sub char_readyP {
  591.     local($ip) = @_ ? @_ : $IPcurrent;
  592.     $IPbuffer{$ip} ne '';    # XXX shouldn't refer to IPbuffer directly.
  593. }
  594.  
  595. &SUBR('read-line', 0, 1, $T_INPUT);    # (extension)
  596. sub read_line {
  597.     local($ip) = @_ ? @_ : $IPcurrent;
  598.     local($_) = &IPget($ip);
  599.     $_ eq '' ? $EOF : &S($_);
  600. }
  601.  
  602. &SUBR('read', 0, 1, $T_INPUT);
  603. sub read {
  604.     local($ip) = @_ ? @_ : $IPcurrent;
  605.     local($_) = &IPgetns($ip);
  606.  
  607.     if ($_ eq '') {
  608.         $EOF;
  609.     } elsif (/^\(/) {
  610.         &IPput($ip, $');
  611.         &L(&RDvec($ip));
  612.     } elsif (/^'/) {
  613.         &IPput($ip, $');
  614.         &P($QUOTE, &P(&read($ip), $NIL));
  615.     } elsif (/^`/) {
  616.         &IPput($ip, $');
  617.         &P($QUASIQUOTE, &P(&read($ip), $NIL));
  618.     } elsif (/^,@/) {
  619.         &IPput($ip, $');
  620.         &P($UNQUOTE_SPLICING, &P(&read($ip), $NIL));
  621.     } elsif (/^,/) {
  622.         &IPput($ip, $');
  623.         &P($UNQUOTE, &P(&read($ip), $NIL));
  624.     } elsif (/^"/) {
  625.         &IPput($ip, $');
  626.         &S(&RDstring($ip));
  627.     } elsif (/^#\(/) {
  628.         &IPput($ip, $');
  629.         &V(&RDvec($ip));
  630.     } elsif (/^(#\\\w\w+)\s*/) {
  631.         local($x) = $1;
  632.         &IPput($ip, $');
  633.         &RDtoken($x);
  634.     } elsif (/^#\\([\0-\377])\s*/) {
  635.         local($c) = $1;
  636.         &IPput($ip, $');
  637.         &C($c);
  638.     } elsif (/^([^()"',\s]+)\s*/) {
  639.         local($x) = $1;
  640.         &IPput($ip, $');
  641.         &RDtoken($x);
  642.     } else {
  643.         &ERR("failure in READ, can't understand $_");
  644.     }
  645. }
  646.  
  647. sub RDtoken {
  648.     local($_) = @_;
  649.     $_ =~ tr/A-Z/a-z/;
  650.  
  651.     if    (/^\.$/)        { '.'; }    # read hack.
  652.     elsif (/^#t$/)        { $TRUE; }
  653.     elsif (/^#f$/)        { $FALSE; }
  654.     elsif (/^#\\space$/)    { &C(' '); }
  655.     elsif (/^#\\newline$/)    { &C("\n"); }
  656.     elsif (/^#\\tab$/)    { &C("\t"); }
  657.  
  658.     elsif (/^#/) {
  659.         &ERR("read, bad token $_");
  660.     } elsif (/^[-+]?(\d+\.?\d*|\d*\.\d+)(e[-+]?\d+)?$/) {
  661.         &N($_ + 0);
  662.     } elsif (/^[-+]?(\d+)\/(\d+)$/) {
  663.         &N($1 / $2);
  664.     } else {
  665.         &Y($_);
  666.     }
  667. }
  668.  
  669. sub RDvec {
  670.     local($ip) = @_;
  671.     local($_, @v);
  672.     while (($_ = &IPgetns($ip)) ne '') {
  673.         &IPput($ip, $'), last if /^\)\s*/;
  674.         &IPput($ip, $_);
  675.         push(@v, &read($ip));
  676.     }
  677.     if ($_ eq '') {
  678.         &ERR("EOF while reading list or vector.");
  679.     }
  680.     return @v;
  681. }
  682.  
  683. sub RDstring {
  684.     local($ip) = @_;
  685.     local($s) = "";
  686.     $_ = &IPget($ip);
  687.     while ($_ ne '') {
  688.         &IPput($ip, $'), last if /^"\s*/;
  689.         if (/^\\([\0-\377])/) {
  690.             $s .= $1; $_ = $';
  691.         } elsif (/^[^"\\]+/) {
  692.             $s .= $&; $_ = $';
  693.         } else {
  694.             $s .= $_; $_ = '';
  695.         }
  696.         $_ = &IPget($ip) if $_ eq '';
  697.     }
  698.     return $s;
  699. }
  700.  
  701. #------
  702. #-- Output.
  703. #------
  704.  
  705. &SUBR('newline', 0, 1, $T_OUTPUT);
  706. sub newline {
  707.     &OPput(@_ ? @_[0] : $OPcurrent, "\n");
  708. }
  709.  
  710. &SUBR('write-char', 1, 2, $T_CHAR, $T_OUTPUT);
  711. sub write_char {
  712.     &OPput(@_ > 1 ? @_[1] : $OPcurrent, &Cval(@_[0]));
  713. }
  714.  
  715. $WRquoted = 0;
  716. %WRmark = ();
  717.  
  718. &SUBR('write', 1, 2, $T_ANY, $T_OUTPUT);
  719. sub write {
  720.     $WRquoted = 1;
  721.     &WR(@_);
  722. }
  723.  
  724. &SUBR('display', 1, 2, $T_ANY, $T_OUTPUT);
  725. sub display {
  726.     $WRquoted = 0;
  727.     &WR(@_);
  728. }
  729. sub WR {
  730.     local(@sip) = @_;
  731.     local($fh) = &OPval(@_ > 1 ? @_[1] : $OPcurrent);
  732.     local($oldfh) = select($fh);
  733.     %WRmark = ();
  734.     &WR1(@_[0]);
  735.     select($oldfh);
  736.     $TRUE;
  737. }
  738.  
  739. sub WR1 {
  740.     local($it) = @_;
  741.     local($t) = &TYPE($it);
  742.     if    ($t == $T_NIL)    { print '()'; }
  743.     elsif ($t == $T_BOOLEAN){ print $it ? '#t' : '#f'; }
  744.     elsif ($t == $T_NUMBER)    { print &Nval($it); }
  745.     elsif ($t == $T_CHAR)    { &WRchar($it); }
  746.     elsif ($t == $T_SYMBOL)    { print &Yname($it); }
  747.     elsif ($t == $T_STRING)    { &WRstring($it); }
  748.     elsif ($t == $T_VECTOR)    { &WRvector($it); }
  749.     elsif ($t == $T_TABLE)    { &WRtable($it); }
  750.     elsif ($t == $T_PAIR)    { &WRlist($it); }
  751.  
  752.     elsif ($t == $T_INPUT) {
  753.         print '#<input port ', &IPval($it), '>';
  754.     } elsif ($t == $T_OUTPUT) {
  755.         print '#<output port ', &OPval($it), '>';
  756.     } elsif ($t == $T_SUBR) {
  757.         print '#<built-in ', (&SUBRval($it))[0], '>';
  758.     } elsif ($t == $T_FORM) {
  759.         print '#<keyword ', (&FORMval($it))[0], '>';
  760.     } else {
  761.         print "#<strange object: $it>";
  762.     }
  763. }
  764.  
  765. sub WRstring {
  766.     local($s) = &Sval(@_[0]);
  767.     if (!$WRquoted) {
  768.         print $s;
  769.     } else {
  770.         $s =~ s/\\/\\\\/g;
  771.         $s =~ s/"/\\"/g;
  772.         print '"', $s, '"';
  773.     }
  774. }
  775.  
  776. sub WRchar {
  777.     local($c) = &Cval(@_[0]);
  778.     if    (!$WRquoted)    { print $c; }
  779.     elsif ($c eq ' ')    { print '#\space'; }
  780.     elsif ($c eq "\n")    { print '#\newline'; }
  781.     elsif ($c eq "\t")    { print '#\tab'; }
  782.     else            { print "#\\$c"; }
  783. }
  784.  
  785. # XXX Can't read a written table.
  786. sub WRtable {
  787.     local($it) = @_;
  788.     return print '{...}' if $WRmark{$it};
  789.     $WRmark{$it} += 3;    # strong bias against printing tables again.
  790.  
  791.     print '{';
  792.     local(@keys) = &Tkeys($it);
  793.     if (@keys) {
  794.         local($k) = pop @keys;
  795.         print $k, ' => ';
  796.         &WR1(&Tval($it, &Y($k)));
  797.     }
  798.     for $k (@keys) {
  799.         print ', ', $k, ' => ';
  800.         &WR1(&Tval($it, &Y($k)));
  801.     }
  802.     print '}';
  803.  
  804.     $WRmark{$it} -= 3;
  805. }
  806.  
  807. sub WRvector {
  808.     local($it) = @_;
  809.     return print '#(...)' if $WRmark{$it};
  810.     ++$WRmark{$it};
  811.  
  812.     local(@v) = &Vval($it);
  813.     print '#(';
  814.     &WR1(shift @v) if @v;
  815.     while (@v) {
  816.         print ' ';
  817.         &WR1(shift @v);
  818.     }
  819.     print ')';
  820.  
  821.     --$WRmark{$it};
  822. }
  823.  
  824. sub WRlist {
  825.     local($it) = @_;
  826.     return print '(...)' if $WRmark{$it};
  827.     local(%save) = %WRmark;
  828.     ++$WRmark{$it};
  829.  
  830.     local($a, $d) = &Pval($it);
  831.     print "(";
  832.     &WR1($a);
  833.     while ($d ne $NIL) {
  834.         if ($WRmark{$d}) {
  835.             print ' ...';
  836.             last;
  837.         } elsif (&TYPE($d) != $T_PAIR) {
  838.             print ' . ';
  839.             &WR1($d);
  840.             last;
  841.         } else {
  842.             ++$WRmark{$d};
  843.             ($a, $d) = &Pval($d);
  844.             print ' ';
  845.             &WR1($a);
  846.         }
  847.     }
  848.     print ')';
  849.  
  850.     %WRmark = %save;
  851. }
  852.  
  853. #------
  854. #-- Control features.
  855. #------
  856.  
  857. # XXX SUBR call-with-current-continuation
  858.  
  859. &SUBR1('procedure?');
  860. sub procedureP {
  861.     local($it) = @_;
  862.     local($t) = &TYPE($it);
  863.     $t == $T_SUBR ||
  864.     ($t == $T_VECTOR && (&Vval($it))[0] eq $CLOSURE);
  865. }
  866.  
  867. &SUBR1('force');
  868. sub force {
  869.     &ERRtype(@_[0], 'a promise', 'force') if &TYPE(@_[0]) ne $T_VECTOR;
  870.     local($thunk) = @_;
  871.     local($k, $forced, $val, $env, @code) = &Vval($thunk);
  872.     &ERRtype($thunk, 'a promise', 'force') if $k ne $PROMISE;
  873.     if (!$forced) {
  874.         &ENVpush($env);
  875.         $val = &begin(@code);
  876.         &ENVpop();
  877.         &Vset($thunk, 1, 2, $TRUE, $val);
  878.     }
  879.     $val;
  880. }
  881.  
  882. &SUBRN('apply');
  883. sub apply {
  884.     local(@sip) = @_;
  885.     local($f, @args) = @_;
  886.     &CHKtype(@args[$#args], $T_LIST, 'apply');
  887.     push(@args, &Lval(pop @args));
  888.     &applyN($f, @args);
  889. }
  890.  
  891. sub applyN {
  892.     local(@args) = @_;
  893.     local($f) = shift @args;
  894.     local($t) = &TYPE($f);
  895.  
  896.     if ($t == $T_SUBR) {
  897.         local($f, $min, $max, @t) = &SUBRval($f);
  898.         if (@args < $min) {
  899.             &ERR("Error, $f needs at least $min arguments.");
  900.         } elsif ($max >= 0 && @args > $max) {
  901.             &ERR("Error, $f wants at most $max arguments.");
  902.         }
  903.         if ($max < 0 && @t[0]) {
  904.             for $x (@args) {
  905.                 &CHKtype($x, @t[0], $f);
  906.             }
  907.         } elsif (@t) {
  908.             local($k) = $#t < $#args ? $#t : $#args;
  909.             for (; $k >= 0; --$k) {
  910.                 &CHKtype(@args[$k], @t[$k], $f);
  911.             }
  912.         }
  913.         return do $f (@args);
  914.  
  915.     } elsif ($t == $T_VECTOR) {
  916.         local($k, $env, $nsym, $n, @code) = &Vval($f);
  917.         &ERRtype($f, $T_PROCEDURE, 'applyN') if $k ne $CLOSURE;
  918.         $n = &Nval($n);
  919.         if (@args < $n) {
  920.             &ERR('not enough args to procedure.');
  921.         } elsif (@args > $n && $nsym eq $NIL) {
  922.             &ERR('too many args to procedure.');
  923.         }
  924.         &ENVpush($env);
  925.         &ENVpush_frame();
  926.         if ($n > 0) {
  927.             &ENVbind(splice(@code, 0, $n), splice(@args, 0, $n));
  928.         }
  929.         if ($nsym ne $NIL) {
  930.             &ENVbind($nsym, &L(@args));
  931.         }
  932.         local($x) = &begin(@code);
  933.         &ENVpop();
  934.         return $x;
  935.  
  936.     } else {
  937.         &ERRtype($f, $T_PROCEDURE, 'applyN');
  938.     }
  939. }
  940.  
  941. &SUBRN('map');
  942. sub map {
  943.     local(@lists) = @_;
  944.     local($f) = &eval(shift @lists);
  945.     local(@result, @args, $a);
  946.     &CHKtype($f, $T_PROCEDURE, 'map');
  947.     # XXX CHKtype lists. and all lists must be same length.
  948.     while (@lists[0] ne $NIL) {
  949.         @args = ();
  950.         for $x (@lists) {
  951.             ($a, $x) = &Pval($x);
  952.             push(@args, $a);
  953.         }
  954.         push(@result, &applyN($f, @args));
  955.     }
  956.     &L(@result);
  957. }
  958.  
  959. &SUBRN('for-each');
  960. sub for_each {
  961.     local(@lists) = @_;
  962.     local($f) = &eval(shift @lists);
  963.     local(@args, $a);
  964.     &CHKtype($f, $T_PROCEDURE, 'for-each');
  965.     # XXX CHKtype lists. and all lists must be same length.
  966.     while (@lists[0] ne $NIL) {
  967.         @args = ();
  968.         for $x (@lists) {
  969.             ($a, $x) = &Pval($x);
  970.             push(@args, $a);
  971.         }
  972.         &applyN($f, @args);
  973.     }
  974.     $TRUE;
  975. }
  976.  
  977.  
  978. sub eval {
  979.     local($it) = @_;
  980.     local($t) = &TYPE($it);
  981.  
  982.     if ($t == $T_SYMBOL) {
  983.         return &ENVval($it);
  984.     } elsif ($t != $T_PAIR) {
  985.         return $it;
  986.     }
  987.  
  988.     local($f, $args) = &Pval($it);
  989.  
  990.     $t = &TYPE($f);
  991.     if ($t == $T_SYMBOL) {
  992.         $f = &ENVval($f);
  993.         $t = &TYPE($f);
  994.     } elsif ($t == $T_PAIR) {
  995.         $f = &eval($f);
  996.         $t = &TYPE($f);
  997.     }
  998.  
  999.     if ($t == $T_FORM) {
  1000.         $f = &FORMval($f);
  1001.         return do $f (&Lval($args));
  1002.     }
  1003.  
  1004.     if ($t != $T_SUBR && $t != $T_VECTOR) {
  1005.         &ERRtype(&car(@_[0]), $T_PROCEDURE, 'eval');
  1006.     }
  1007.  
  1008.     local(@args) = &Lval($args);
  1009.     for $a (@args) { $a = &eval($a); }
  1010.     &applyN($f, @args);
  1011. }
  1012.  
  1013. #------
  1014. #-- User interface.
  1015. #------
  1016.  
  1017. &SUBR1('load', $T_STRING);
  1018. sub load {
  1019.     local($f) = &Sval(@_[0]);
  1020.     local($ip) = &IP($f . '.sp') || &IP($f) ||
  1021.         &ERR("load, neither $f nor $f.sp found.");
  1022.  
  1023.     print $stderr "Loading $f...\n";
  1024.  
  1025.     local($x, $y);
  1026.     while (($x = &read($ip)) ne $EOF) {
  1027.         $y = &eval($x);
  1028.     }
  1029.     close(&IPval($ip));
  1030.  
  1031.     $y;
  1032. }
  1033.  
  1034. # XXX SUBR transcript-on, transcript-off
  1035.  
  1036. &SUBR('exit', 0, 1, $T_NUMBER);
  1037. sub exit {
  1038.     local($x) = @_ ? &Nval(@_[0]) : 0;
  1039.     &DB'prof_dump if defined &DB'prof_dump;
  1040.     exit $x;
  1041. }
  1042.  
  1043. &SUBR0('sp-version');
  1044. sub sp_version {
  1045.     &N($version);
  1046. }
  1047.  
  1048. sub repl {
  1049.     local($x);
  1050.     while {
  1051.         print "> ";
  1052.         $x = &read();
  1053.         $x ne $EOF;
  1054.     } {
  1055.         $x = &eval($x);
  1056.         print "\n";
  1057.         &write($x);
  1058.         print "\n";
  1059.     }
  1060. }
  1061.  
  1062. #------
  1063. #-- Main program.
  1064. #------
  1065.  
  1066. sub catch_interrupt {
  1067.     print $stderr "Interrupt\n";
  1068.     goto TOP;    # Not quite a safe thing to do.
  1069. }
  1070.  
  1071. $# = '%.15g';    # the default, %.20g, is a little too many digits.
  1072.  
  1073. INIT:;
  1074.  
  1075. &IOinit();
  1076.  
  1077. $TOPjmp = 0;
  1078.  
  1079. TOP:;
  1080.  
  1081. &IOreset();
  1082. &ENVreset();
  1083.  
  1084. if ($TOPjmp) {
  1085.     print $stderr "\nContinuing from top...\n";
  1086. } else {
  1087.     $TOPjmp = 1;
  1088.     print $stderr "Scheme in Perl? (sp?)\n";
  1089.     print $stderr "  version $version\n";
  1090. }
  1091.  
  1092. if (! @ARGV) {
  1093.     $SIG{'INT'} = 'catch_interrupt';
  1094.     &repl();
  1095. } else {
  1096.     $dodump = (@ARGV[0] eq '-D') && shift @ARGV;
  1097.     for $x (@ARGV) {
  1098.         &load(&S($x));
  1099.     }
  1100.     if ($dodump) {
  1101.         &IOshutdown();
  1102.         dump INIT;
  1103.     }
  1104. }
  1105.  
  1106. &exit();
  1107.