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 (concatenate) 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     obj _mal_function? { % if user defined function
  39         (<\(fn* )
  40         obj /params get print_readably _pr_str
  41         ( )
  42         obj /ast get print_readably _pr_str
  43         (\)>)
  44         concatenate concatenate concatenate concatenate
  45     }{ /arraytype obj type eq { % if list or code block
  46         % accumulate an array of strings
  47         func? { (<builtin_fn* { ) }{ (\() } ifelse
  48         obj ( ) print_readably _pr_str_args
  49         concatenate
  50         func? { ( } >) }{ (\)) } ifelse
  51         concatenate
  52     }{ /integertype obj type eq { % if number
  53         /slen obj 10 add log ceiling cvi def
  54         obj 10 slen string cvrs
  55     }{ /stringtype obj type eq { % if string
  56         print_readably {
  57             (") obj (") concatenate concatenate
  58         }{
  59             obj
  60         } ifelse
  61     }{ null obj eq { % if nil
  62         (nil)
  63     }{ true obj eq { % if true
  64         (true)
  65     }{ false obj eq { % if false
  66         (false)
  67     }{ /nametype obj type eq { % if symbol
  68         obj dup length string cvs
  69     }{
  70         (<unknown>)
  71     } ifelse } ifelse } ifelse } ifelse } ifelse } ifelse } ifelse } ifelse
  72 end } def
  73
  74 % array delim print_readably -> _pr_str_args -> new_string
  75 /_pr_str_args { 3 dict begin
  76     /print_readably exch def
  77     /delim exch def
  78     /args exch def
  79     ()
  80     args length 0 gt { %if any elements
  81         [
  82             args { %foreach argument in array
  83                 print_readably _pr_str
  84             } forall
  85         ]
  86         { concatenate delim concatenate } forall
  87         dup length delim length sub 0 exch getinterval % strip off final delim
  88     } if
  89 end } def
  90
  91 % objA objB -> _equal? -> bool
  92 /_equal? { 6 dict begin
  93     /b exch def
  94     /a exch def
  95     /ota a type def
  96     /otb b type def
  97
  98     a type b type eq
  99     a _list? b _list? and
 100     or not { %if type mismatch and not sequential
 101         false
 102     }{
 103         a _list? { %if list
 104             /ret true def
 105             a length b length eq not { %if length mismatch
 106                 /ret false def
 107             }{ %else (length is the same)
 108                 0 1 a length 1 sub {
 109                     /idx exch def
 110                     a idx get b idx get _equal? not { %if not items _equal?
 111                         /ret false def
 112                         exit
 113                     } if
 114                 } for
 115             } ifelse
 116             ret
 117         }{ %else not a list
 118             a b eq
 119         } ifelse
 120     } ifelse
 121 end } def
 122
 123 /_nil? { null eq } def
 124 /_true? { true eq } def
 125 /_false? { false eq } def
 126
 127
 128 %
 129 % Symbols
 130 %
 131 /_symbol? {
 132     type /nametype eq
 133 } def
 134
 135 %
 136 % Functions
 137 %
 138 /_mal_function? {
 139     dup type /dicttype eq {
 140         /type get /_maltype_function eq
 141     }{
 142         pop false
 143     } ifelse
 144 } def
 145
 146 % args mal_function -> fload -> ast new_env
 147 % fload: sets up arguments on the stack for an EVAL call
 148 /fload {
 149     dup /ast get 3 1 roll    % stack: ast args mal_function
 150     dup /env get 3 1 roll    % stack: ast env args mal_function
 151     /params get exch         % stack: ast env params args
 152     env_new                  % stack: ast new_env
 153 } def
 154
 155 % function_or_block -> callable -> block
 156 % if this is a user defined mal function, get its executable block
 157 /callable { dup _mal_function? { /data get } if } def
 158
 159 %
 160 % Errors/Exceptions
 161 %
 162
 163 % data -> throw ->
 164 % Takes an arbitrary data and puts it in $error:/errorinfo. Then calls
 165 % stop to transfer control to end of nearest stopped context.
 166 /throw {
 167     $error exch /errorinfo exch put
 168     $error /command /throw put
 169     stop
 170 } def
 171
 172 /errorinfo? {
 173     $error /errorinfo known { % if set
 174         $error /errorinfo get null ne {
 175             true
 176         }{
 177             false
 178         } ifelse
 179     }{
 180         false
 181     } ifelse
 182 } def
 183
 184 /get_error_data {
 185     errorinfo? { %if
 186         $error /errorinfo get
 187     }{
 188         $error /errorname get 255 string cvs
 189         (: )
 190         $error /command get 99 string cvs
 191         ( at )
 192         $error /position get 10 99 string cvrs
 193         concatenate
 194         concatenate
 195         concatenate
 196         concatenate
 197     } ifelse
 198 } def
 199
 200
 201
 202 %
 203 % list operations
 204 %
 205 /_list {
 206     array astore
 207 } def
 208 /_list? {
 209     dup xcheck not exch type /arraytype eq and
 210 } def
 211 /_nth { get } def
 212
 213 /_cons {
 214     /lst exch def
 215     /elem exch def
 216     lst length 1 add array
 217     dup 0 elem put % first element
 218     dup 1 lst putinterval % rest of the elements
 219 } def
 220
 221 /concat { % replaces matric concat
 222     dup length 0 eq { %if just concat
 223         0 _list
 224     }{ dup length 1 eq { %elseif concat of single item
 225         0 get % noop
 226     }{ % else
 227         [] exch
 228         {
 229             concatenate
 230         } forall
 231     } ifelse } ifelse
 232 } def
 233
 234 %
 235 % Sequence operations
 236 %
 237 /_first {
 238     dup length 0 gt { 0 get }{ pop null } ifelse
 239 } def
 240 /_rest {
 241     dup length 0 gt {
 242         dup length 1 sub 1 exch getinterval
 243     }{
 244         pop 0 array
 245     } ifelse
 246 } def
 247
 248 % [function args... arg_list] -> apply -> result
 249 /apply { 1 dict begin
 250     /args exch def
 251     args 0 get callable % make sure function is callable
 252     args 1 args length 2 sub getinterval
 253     args args length 1 sub get
 254     concatenate args 0 get % stack: args function
 255     exec
 256 end } def
 257
 258 % function list -> _map -> new_list
 259 /_map { 1 dict begin
 260     /args exch def
 261     callable % make sure function is callable
 262     %/new_list args length array def
 263     args {
 264         1 array astore
 265         exch dup 3 1 roll % stack: fn arg fn
 266         exec exch % stack: result fn
 267     } forall
 268     pop % remove the function
 269     args length array astore
 270 end } def
 271
 272 /_sequential? { _list? } def
 273
 274 /conj { 5 dict begin
 275     /args exch def
 276     /src_list args 0 get def
 277     /new_len src_list length   args length 1 sub   add def
 278     /new_list new_len array def
 279     new_list   new_len src_list length sub   src_list putinterval
 280     args length 1 sub -1 1 {
 281         /idx exch def
 282         new_list   args length idx sub 1 sub   args idx get   put
 283     } for
 284     new_list
 285 end } def
 286
 287
 288 %
 289 % Env implementation
 290 %
 291 % outer binds exprs -> env_new -> new_env
 292 /env_new { 3 dict begin
 293     %(in env_new\n) print
 294     /exprs exch def
 295     /binds exch def
 296     /outer exch def
 297     <<
 298         /__outer__ outer
 299         0 1 binds length 1 sub {
 300             /idx exch def
 301             binds idx get (&) eq { %if &
 302                 binds idx 1 add get % key
 303                 exprs idx   exprs length idx sub   getinterval % value
 304                 exit
 305             } if
 306             binds idx get % key
 307             exprs idx get % value
 308         } for
 309     >>
 310 end } def
 311
 312 /env_find { 2 dict begin
 313     /key exch def
 314     /env exch def
 315     env key known { %if key in env
 316         env
 317     }{ env /__outer__ get null ne { %elseif __outer__ not null
 318         env /__outer__ get   key env_find
 319     }{ %else
 320         null
 321     } ifelse } ifelse
 322 end } def
 323
 324 /env_set { 4 dict begin
 325     dup
 326     /func? exch xcheck def % executable function
 327     /val exch cvlit def
 328     /key exch def
 329     /env exch def
 330     env key val func? { cvx } if put
 331     val func? { cvx } if
 332 end } def
 333
 334 /env_get { 2 dict begin
 335     /key exch def
 336     /env exch def
 337     env key env_find
 338     dup null eq {
 339         (')
 340         key 99 string cvs
 341         (' not found)
 342         concatenate concatenate
 343         throw
 344     }{
 345         key get
 346     } ifelse
 347 end } def
 348
 349 %
 350 % types_ns is namespace of type functions
 351 %
 352 /types_ns <<
 353     (pr-str)  { ( ) true _pr_str_args }
 354     (str)     { () false _pr_str_args }
 355     (prn)     { ( ) true _pr_str_args print (\n) print null }
 356     (println) { () false _pr_str_args print (\n) print null }
 357     (=)       { dup 0 get exch 1 get _equal? }
 358     (symbol?) { 0 get _symbol? }
 359     (nil?)    { 0 get _nil? }
 360     (true?)   { 0 get _true? }
 361     (false?)  { 0 get _false? }
 362     (<)       { dup 0 get exch 1 get lt }
 363     (<=)      { dup 0 get exch 1 get le }
 364     (>)       { dup 0 get exch 1 get gt }
 365     (>=)      { dup 0 get exch 1 get ge }
 366     (+)       { dup 0 get exch 1 get add }
 367     (-)       { dup 0 get exch 1 get sub }
 368     (*)       { dup 0 get exch 1 get mul }
 369     (/)       { dup 0 get exch 1 get idiv }
 370     (throw)   { 0 get throw }
 371     (list)    { dup pop } % noop
 372     (list?)   { 0 get _list? }
 373     (cons)    { dup 0 get exch 1 get _cons }
 374     (concat)  { concat }
 375     (sequential?) { 0 get _sequential? }
 376     (empty?)  { 0 get length 0 eq }
 377     (count)   { 0 get length }
 378     (nth)     { dup 0 get exch 1 get _nth }
 379     (first)   { 0 get _first }
 380     (rest)    { 0 get _rest }
 381     (apply)   { apply }
 382     (map)     { dup 0 get exch 1 get _map }
 383     (conj)    { conj }
 384 >> def