ps/types.ps

   1 (in types.ps\n) print
   2
   3 % concatenate: concatenate two strings or two arrays
   4 % From Thinking in PostScript 1990 Reid
   5 % (string1) (string2) concatenate string3
   6 % array1 array2 concatenate array3
   7 /concatenate { %def
   8     dup type 2 index type 2 copy ne { %if
   9         pop pop
  10         errordict begin (concatentate) typecheck end
  11     }{ %else
  12         /stringtype ne exch /arraytype ne and {
  13             errordict begin (concatenate) typecheck end
  14         } if
  15     } ifelse
  16     dup length 2 index length add 1 index type
  17     /arraytype eq { array }{ string } ifelse
  18     % stack: arg1 arg2 new
  19     dup 0 4 index putinterval
  20     % stack: arg1 arg2 new
  21     dup 4 -1 roll length 4 -1 roll putinterval
  22     % stack: new
  23 } bind def
  24
  25 % reverse: array1 -> reverse -> array2
  26 /reverse {
  27     [ exch
  28     aload % push array onto stack
  29     length -1 0 { 1 roll } for % reverse
  30     ]
  31 } bind def
  32
  33 /_pr_str { 4 dict begin
  34     /print_readably exch def
  35     dup
  36     /func? exch xcheck def % executable function
  37     /obj exch cvlit def
  38     /arraytype obj type eq { % if list
  39         % accumulate an array of strings
  40         func? { (<fn* { ) }{ (\() } ifelse
  41         obj ( ) print_readably _pr_str_args
  42         concatenate
  43         func? { ( } >) }{ (\)) } ifelse
  44         concatenate
  45     }{ /integertype obj type eq { % if number
  46         /slen obj 10 add log ceiling cvi def
  47         obj 10 slen string cvrs
  48     }{ /stringtype obj type eq { % if string
  49         print_readably {
  50             (") obj (") concatenate concatenate
  51         }{
  52             obj
  53         } ifelse
  54     }{ null obj eq { % if nil
  55         (nil)
  56     }{ true obj eq { % if true
  57         (true)
  58     }{ false obj eq { % if false
  59         (false)
  60     }{ /nametype obj type eq { % if symbol
  61         obj dup length string cvs
  62     }{
  63         (<unknown>)
  64     } ifelse } ifelse } ifelse } ifelse } ifelse } ifelse } ifelse
  65 end } def
  66
  67 % array delim print_readably -> _pr_str_args -> new_string
  68 /_pr_str_args { 3 dict begin
  69     /print_readably exch def
  70     /delim exch def
  71     /args exch def
  72     ()
  73     args length 0 gt { %if any elements
  74         [
  75             args { %foreach argument in array
  76                 print_readably _pr_str
  77             } forall
  78         ]
  79         { concatenate delim concatenate } forall
  80         dup length delim length sub 0 exch getinterval % strip off final delim
  81     } if
  82 end } def
  83
  84 % objA objB -> _equal? -> bool
  85 /_equal? { 6 dict begin
  86     /b exch def
  87     /a exch def
  88     /ota a type def
  89     /otb b type def
  90
  91     a type b type eq
  92     a _list? b _list? and
  93     or not { %if type mismatch and not sequential
  94         false
  95     }{
  96         a _list? { %if list
  97             /ret true def
  98             a length b length eq not { %if length mismatch
  99                 /ret false def
 100             }{ %else (length is the same)
 101                 0 1 a length 1 sub {
 102                     /idx exch def
 103                     a idx get b idx get _equal? not { %if not items _equal?
 104                         /ret false def
 105                         exit
 106                     } if
 107                 } for
 108             } ifelse
 109             ret
 110         }{ %else not a list
 111             a b eq
 112         } ifelse
 113     } ifelse
 114 end } def
 115
 116
 117 %
 118 % errors/exceptions
 119 %
 120
 121 % data -> throw ->
 122 % Takes an arbitrary data and puts it in $error:/errorinfo. Then calls
 123 % stop to transfer control to end of nearest stopped context.
 124 /throw {
 125     $error exch /errorinfo exch put
 126     $error /command /throw put
 127     stop
 128 } def
 129
 130 /errorinfo? {
 131     $error /errorinfo known { % if set
 132         $error /errorinfo get null ne {
 133             true
 134         }{
 135             false
 136         } ifelse
 137     }{
 138         false
 139     } ifelse
 140 } def
 141
 142 /get_error_data {
 143     errorinfo? { %if
 144         $error /errorinfo get
 145     }{
 146         $error /errorname get 255 string cvs
 147         (: )
 148         $error /command get 99 string cvs
 149         ( at )
 150         $error /position get 10 99 string cvrs
 151         concatenate
 152         concatenate
 153         concatenate
 154         concatenate
 155     } ifelse
 156 } def
 157
 158
 159
 160 %
 161 % list operations
 162 %
 163 /_list? {
 164     dup xcheck not exch type /arraytype eq and
 165 } def
 166 /_first { 0 get } def
 167 /_rest { dup length 1 sub 1 exch getinterval } def
 168 /_nth { get } def
 169
 170
 171 %
 172 % Env implementation
 173 %
 174 % outer binds exprs -> env_new -> new_env
 175 /env_new { 3 dict begin
 176     %(in env_new\n) print
 177     /exprs exch def
 178     /binds exch def
 179     /outer exch def
 180     <<
 181         /__outer__ outer
 182         0 1 binds length 1 sub {
 183             /idx exch def
 184             binds idx get (&) eq { %if &
 185                 binds idx 1 add get % key
 186                 exprs idx   exprs length idx sub   getinterval % value
 187                 exit
 188             } if
 189             binds idx get % key
 190             exprs idx get % value
 191         } for
 192     >>
 193 end } def
 194
 195 /env_find { 2 dict begin
 196     /key exch def
 197     /env exch def
 198     env key known { %if key in env
 199         env
 200     }{ env /__outer__ get null ne { %elseif __outer__ not null
 201         env /__outer__ get   key env_find
 202     }{ %else
 203         null
 204     } ifelse } ifelse
 205 end } def
 206
 207 /env_set { 4 dict begin
 208     dup
 209     /func? exch xcheck def % executable function
 210     /val exch cvlit def
 211     /key exch def
 212     /env exch def
 213     env key val func? { cvx } if put
 214     val func? { cvx } if
 215 end } def
 216
 217 /env_get { 2 dict begin
 218     /key exch def
 219     /env exch def
 220     env key env_find
 221     dup null eq {
 222         (')
 223         key 99 string cvs
 224         (' not found)
 225         concatenate concatenate
 226         throw
 227     }{
 228         key get
 229     } ifelse
 230 end } def
 231
 232 %
 233 % types_ns is namespace of type functions
 234 %
 235 /types_ns <<
 236     (pr-str)  { ( ) true _pr_str_args }
 237     (str)     { () false _pr_str_args }
 238     (prn)     { ( ) true _pr_str_args print (\n) print null }
 239     (println) { () false _pr_str_args print (\n) print null }
 240     (=)       { dup 0 get exch 1 get _equal? }
 241     (<)       { dup 0 get exch 1 get lt }
 242     (<=)      { dup 0 get exch 1 get le }
 243     (>)       { dup 0 get exch 1 get gt }
 244     (>=)      { dup 0 get exch 1 get ge }
 245     (+)       { dup 0 get exch 1 get add }
 246     (-)       { dup 0 get exch 1 get sub }
 247     (*)       { dup 0 get exch 1 get mul }
 248     (/)       { dup 0 get exch 1 get idiv }
 249     (list)    { }
 250     (list?)   { 0 get _list? }
 251     (empty?)  { 0 get length 0 eq }
 252     (count)   { 0 get length }
 253 >> def