home *** CD-ROM | disk | FTP | other *** search
/ InfoMagic Source Code 1993 July / THE_SOURCE_CODE_CD_ROM.iso / languages / perl / scripts-convex / recurse.pl < prev    next >
Encoding:
Perl Script  |  1992-08-18  |  6.1 KB  |  278 lines
  1. #!/usr/bin/perl
  2.  
  3. ###
  4. ###Date:         28 Nov 90 10:48:56 GMT
  5. ###From:         flee@dictionopolis.cs.psu.edu (Felix Lee)
  6. ###Subject:      Recursive types in Perl.
  7. ###Organization: Penn State Computer Science
  8. ###Newsgroups:   comp.lang.perl
  9. ###Message-ID:   <F-ade_g3@cs.psu.edu>
  10. ###Nntp-Posting-Host: dictionopolis.cs.psu.edu
  11. ###
  12. ###
  13. ###Below, recurse.pl, a simulation of recursive types in Perl.
  14. ###
  15. ###recurse.pl introduces Vectors and Tables, which are mostly just
  16. ###encapsulations of Perl's lists and associative arrays.  Vectors and
  17. ###Tables are represented by strings prefixed by a magic cookie.  Any
  18. ###random string that just happens to have that magic cookie may be
  19. ###mistaken for a Vector or a Table with strange results.  This is an
  20. ###unavoidable flaw.  Hopefully, this will happen rarely.
  21. ###
  22. ###I don't have any sample code that uses Vectors and Tables, because I
  23. ###don't seem to have a use for them right now.  I'm sure I used to have
  24. ###one, but it seems to have dropped by the wayside.  Well, there's
  25. ###Scheme-in-Perl? (sp?), but that's not quite a sample piece of code.
  26. ###
  27. ###sp? was useful experience in building recurse.pl.  recurse.pl fell
  28. ###into place quite quickly.  It's very different from what I might have
  29. ###done a month ago.
  30. ###
  31. ###Given Vectors, you can build true multidimensional arrays, instead of
  32. ###using the $; hack.  Unfortunately, it's likely to be much slower (Perl
  33. ###subroutine call overhead is quite large).  But you can easily slice
  34. ###the multidimensional array, which the $; hack doesn't let you do.
  35. ###--
  36. ###Felix Lee       flee@cs.psu.edu
  37. ###
  38.  
  39. # Recursive types in Perl.  $Revision: 1.1 $
  40.  
  41. # This is an implementation of two recursive types in Perl:
  42. # Vectors and Tables.
  43.  
  44. # Vectors and Tables can be carried around like any scalar
  45. # value in Perl.  They're distinguished from other scalar
  46. # values by a special prefix,
  47. #    "\0*v-" for Vectors, and
  48. #    "\0*t-" for Tables.
  49. # If you happen to have a string that starts with one of
  50. # those values, then it may be misinterpreted.  This is an
  51. # unavoidable flaw.
  52.  
  53. # XXX assumes you haven't mucked with $[.
  54.  
  55. package recurse;
  56.  
  57. # $recurse'error
  58. #   Subroutine to call when a typecheck error occurs.
  59.  
  60. $error = "recurse'die_with_prejudice";
  61.  
  62. sub recurse'die_with_prejudice {
  63.     local($where, $what) = @_;
  64.     die "** recurse: invalid arg to $where: $what\n";
  65. }
  66.  
  67.  
  68. # &isV($x)
  69. #   Return 1 if $x is a Vector, 0 otherwise.
  70.  
  71. sub main'isV {
  72.     @_[0] =~ /^\0\*v-/ || 0;
  73. }
  74.  
  75. # &V(@value)
  76. #   Create a new Vector with the given value.
  77.  
  78. sub main'V {
  79.     local(*v) = local($z) = @ZV ? pop @ZV : "ZV" . ++$ZV;
  80.     @v = @_;
  81.     "\0*v-" . $z;
  82. }
  83.  
  84. # &Vref("name")
  85. #   Create a Vector that's a reference to @name.
  86.  
  87. sub main'Vref {
  88.     if (@_[0] =~ /'/) {
  89.         "\0*v-" . @_[0];
  90.     } else {
  91.         "\0*v-" . (caller)[0] . "'" . @_[0];
  92.     }
  93. }
  94.  
  95. # &Vfree($v)
  96. #   Reclaim the storage occupied by Vector v.
  97.  
  98. sub main'Vfree {
  99.     return do $error('Vfree', @_[0]) if @_[0] !~ /^\0\*v-/;
  100.     local($z) = $';
  101.     push(@ZV, $z) if $z =~ /^ZV\d/;
  102.     local(*v) = $z;
  103.     @v = ();
  104. }
  105.  
  106. # &Vval($v)
  107. #   Return Vector v as a list.
  108. #   (In a scalar context, return the length.)
  109. # &Vval($v, $index, ...)
  110. #   Return a slice of Vector v.
  111.  
  112. sub main'Vval {
  113.     return do $error('Vval', @_[0]) if @_[0] !~ /^\0\*v-/;
  114.     local(*v) = $';
  115.     shift @_;
  116.     @_ ? @v[@_] : @v;
  117. }
  118.  
  119. # &Vset($v, ($index, $value), ...)
  120. #   Set some values in Vector v.
  121.  
  122. sub main'Vset {
  123.     return do $error('Vset', @_[0]) if @_[0] !~ /^\0\*v-/;
  124.     local(*v) = $';
  125.     shift @_;
  126.     @v[shift @_] = shift @_ while @_;
  127. }
  128.  
  129. # &Vsplice($v, $start, $length, $value, ...)
  130. #   Replace a segment of Vector v with the given values
  131. #   and return the old value.
  132.  
  133. sub main'Vsplice {
  134.     return do $error('Vsplice', @_[0]) if @_[0] !~ /^\0\*v-/;
  135.     local(*v) = $';
  136.     shift @_;
  137.     splice(@v, @_);
  138. }
  139.  
  140. # &Vpush($v, $value, ...)
  141. #   Append the given values to Vector v.
  142.  
  143. sub main'Vpush {
  144.     return do $error('Vpush', @_[0]) if @_[0] !~ /^\0\*v-/;
  145.     local(*v) = $';
  146.     shift @_;
  147.     push(@v, @_);
  148. }
  149.  
  150. # &Vpop($v)
  151. #   Remove and return the last element of Vector v.
  152.  
  153. sub main'Vpop {
  154.     return do $error('Vpop', @_[0]) if @_[0] !~ /^\0\*v-/;
  155.     local(*v) = $';
  156.     pop @v;
  157. }
  158.  
  159. # &Vshift($v)
  160. #   Remove and return the first element of Vector v.
  161.  
  162. sub main'Vshift {
  163.     return do $error('Vshift', @_[0]) if @_[0] !~ /^\0\*v-/;
  164.     local(*v) = $';
  165.     shift @v;
  166. }
  167.  
  168. # &Vunshift($v, $value, ...)
  169. #   Prepend the given values to Vector v.
  170.  
  171. sub main'Vunshift {
  172.     return do $error('Vunshift', @_[0]) if @_[0] !~ /^\0\*v-/;
  173.     local(*v) = $';
  174.     shift @_;
  175.     unshift(@v, @_);
  176. }
  177.  
  178.  
  179.  
  180. # &isT($x)
  181. #   Return 1 if $x is a Table, 0 otherwise.
  182.  
  183. sub main'isT {
  184.     @_[0] =~ /\0\*t-/ || 0;
  185. }
  186.  
  187. # &T(%value)
  188. #   Return a new Table with the given value.
  189.  
  190. sub main'T {
  191.     local(*t) = local($z) = @ZT ? pop @ZT : "\ZT" . ++$ZT;
  192.     %t = @_;
  193.     "\0*t-" . $z;
  194. }
  195.  
  196. # &Tref("name")
  197. #   Return a Table that's a reference to %name.
  198.  
  199. sub main'Tref {
  200.     if (@_[0] =~ /'/) {
  201.         "\0*t-" . @_[0];
  202.     } else {
  203.         "\0*t-" . (caller)[0] . "'" . @_[0];
  204.     }
  205. }
  206.  
  207. # &Tfree($t)
  208. #   Reclaim the storage occupied by Table t.
  209.  
  210. sub main'Tfree {
  211.     return do $error('Tfree', @_[0]) if @_[0] !~ /^\0\*t-/;
  212.     local($z) = $';
  213.     push(@ZT, $z) if $z =~ /^ZT\d/;
  214.     local(*t) = $z;
  215.     %t = ();
  216. }
  217.  
  218. # &Tset($t, ($key, $value), ...)
  219. #   Set some (key, value) pairs in Table t.
  220.  
  221. sub main'Tset {
  222.     return do $error('Tset', @_[0]) if @_[0] !~ /^\0\*t-/;
  223.     local(*t) = $';
  224.     shift @_;
  225.     $t{shift @_} = shift @_ while @_;
  226. }
  227.  
  228. # &Tdelete($t, $key, ...)
  229. #   Delete some pairs from Table t.
  230.  
  231. sub main'Tdelete {
  232.     return do $error('Tdelete', @_[0]) if @_[0] !~ /^\0\*t-/;
  233.     local(*t) = $';
  234.     shift @_;
  235.     delete $t{shift @_} while @_;
  236. }
  237.  
  238. # &Tval($t)
  239. #   Return Table t as a list.
  240. # &Tval($t, $key, ...)
  241. #   Return a slice of Table t.
  242.  
  243. sub main'Tval {
  244.     return do $error('Tval', @_[0]) if @_[0] !~ /^\0\*t-/;
  245.     local(*t) = $';
  246.     shift @_;
  247.     @_ ? @t{@_} : %t;
  248. }
  249.  
  250. # &Tkeys($t)
  251. #   Return a list of the keys of Table t.
  252.  
  253. sub main'Tkeys {
  254.     return do $error('Tkeys', @_[0]) if @_[0] !~ /^\0\*t-/;
  255.     local(*t) = $';
  256.     keys %t;
  257. }
  258.  
  259. # &Tvalues($t)
  260. #   Return a list of the values of Table t.
  261.  
  262. sub main'Tvalues {
  263.     return do $error('Tvalues', @_[0]) if @_[0] !~ /^\0\*t-/;
  264.     local(*t) = $';
  265.     values %t;
  266. }
  267.  
  268. # &Teach($t)
  269. #   Return the next (key, value) pair from Table t.
  270.  
  271. sub main'Teach {
  272.     return do $error('Teach', @_[0]) if @_[0] !~ /^\0\*t-/;
  273.     local(*t) = $';
  274.     each %t;
  275. }
  276.  
  277. 1;
  278.