Object.pm 12.9 KB
Newer Older
Juergen Nickelsen's avatar
Juergen Nickelsen committed
1
## Object representations, the low-level details of the objects, and
2 3 4
## create/set/get functions, also in parts for strings and numbers, although
## these are actually just Perl numbers and strings. (And as such, only
## partially distinguishable.)
5

Juergen Nickelsen's avatar
Juergen Nickelsen committed
6
package Object;
7 8 9

use warnings;
use strict;
10
use 5.014;
11
use Carp;
12

13
use Scalar::Util qw(looks_like_number);
14
use Data::Dumper;
15

16 17 18 19 20 21 22
use Global;

use vars qw(@ISA @EXPORT);
use Exporter ();

BEGIN {
        @ISA = qw(Exporter);
23
        @EXPORT = qw( intern cons car cdr listp symbolp numberp stringp
24
                      consp symbol_name symbol_function functionp cxr type_of
25
                      rplaca rplacd fset function put get symbol_plist
26 27
                      specialp cadr cddr function_type function_code
                      symbol_value set function_name is_nil all_symbols remprop
28
                      function_documentation is_t cons_count function_params
29
                      enter_environment backto_environment bind defvar
30
                      environmentp function_env the_environment
31
                      symbol_value_in_env env_vars
32
                    );
33 34
}

35 36 37 38
######## Variables

my %symbols = ();                       # table of all symbols
my $cons_counter = 0;                   # for eval statistics
39 40
my $root_Env;                           # the global environment
my $Env;                                # the current environment
41

42

43 44 45 46
######## Symbols
# a symbol is a hash: { name => "name", func => $function, ... }
# the property list is actually the hash itself, so you can access all
# properties [sic] of a symbol from Lisp
47

48 49 50 51
# return the symbol with the specified name; create it, if necessary
sub intern {
        my ($name) = @_;
        return $symbols{$name} //= bless({ name => $name }, $n_Symbol);
52 53
}

54 55 56 57 58 59 60 61
# create a variable in the root environment; set its value if it hasn't existed
# before
sub defvar {
        my ($sym, $initial, $docstring) = @_;
        $sym->{doc} = $docstring // '';
        my $name = symbol_name($sym);
        $root_Env->{$name} = $initial unless exists($root_Env->{$name});
        return $sym;
62 63
}

64 65 66 67 68
# bind a value to a symbol in (only) the current environment
sub bind {
        my ($sym, $value) = @_;
        my $name = symbol_name($sym);
        $Env->{$name} = $value;
69 70
}

71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87
# set the variable value of a symbol; the variable's bindingis looked up in the
# current environment including its parents; throw an error if the variable is
# not bound, except if the value is undef (need this for makunbound, even if the
# variable is not bound already)
sub set {
        my ($sym, $value, $env) = @_;

        # confess("\$sym undefined") unless defined($sym);
        my $name = symbol_name($sym);
        return $env->{$name} = $value if $env;
                
        for (my $env = $Env; $env != $Nil; $env = $env->{$n_parentenv}) {
                # warn("search env ", $env->{$n_env_name}, " for ", $name);
                if (exists($env->{$name})) {
                        # warn("set $name in ", $env->{$n_env_name});
                        return $env->{$name} = $value;
                }
88
        }
89 90 91
        error("set/setq for undefined variable %s", $sym)
            if defined($value);         # enable makunbound on undefined
                                        # variables
92 93
}

94 95 96 97 98 99 100 101 102
# set the function value of a symbol
sub fset {
        my ($ob, $func) = @_;
        $ob->{func} = $func;
        #print(Dumper($ob));
        
}

# set a property value of a symbol
103 104
sub put {
        my ($ob, $name, $value) = @_;
105
        return $ob->{symbol_name($name)} = $value;
106 107
}

108
# get a property value of a symbol
109 110
sub get {
        my ($ob, $name, $default) = @_;
111
        return $ob->{symbol_name($name)} // $default;
112 113
}

114
# remove a property value of a symbol
115 116
sub remprop {
        my ($ob, $name) = @_;
117
        return delete($ob->{symbol_name($name)});
118 119
}

120
# return the property list of a symbol
121 122
sub symbol_plist {
        my ($ob) = @_;
123
        my $result = $Nil;
124
        while ((my ($key, $value) = each(%{$ob}))) {
125 126 127
                $result = cons(intern($key), cons($value, $result));
        }
        return $result;
128 129
}

130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162
# return true iff a symbol is already created
sub symbol_exists {
        my ($name) = @_;
        return exists($symbols{$name});
}

# return the name of a symbol as a string
sub symbol_name {
        my ($ob) = @_;
        return $ob->{name};
}

# return the value bound to a symbol, or undef if it isn't bound; this searches
# through the current environment and its parents
sub symbol_value {
        my ($ob, $env, $noparents) = @_;
        $env //= $Env;
        my $name = symbol_name($ob);
        for ( ; $env != $Nil; $env = $env->{$n_parentenv}) {
                if (exists($env->{$name})) {
                        return $env->{$name};
                }
                last if $noparents;
        }
        return undef;
}

# return the function bound to a symbol
sub symbol_function {
        my ($ob) = @_;
        return $ob->{func};
}

163
# return an array with all symbols
Juergen Nickelsen's avatar
Juergen Nickelsen committed
164
sub all_symbols {
165
        my ($env) = @_;
166 167
        my @vals = values(%symbols);
        return @vals;
Juergen Nickelsen's avatar
Juergen Nickelsen committed
168 169
}

170 171 172 173
######## Pairs
# a pair is a hash, too: { car => ..., cdr => ... }
# there are no other fields in a hash

174
# return a new cons made from car and  cdr
175 176 177 178 179 180
sub cons {
        my ($car, $cdr) = @_;
        $cons_counter++;
        return bless({ car => $car, cdr => $cdr }, $n_Pair);
}

181
# get or set the current cons counter, for statistical porpoises
182 183 184 185 186 187 188
sub cons_count {
        my ($new) = @_;
        my $count = $cons_counter;
        $cons_counter = $new if defined($new);
        return $count;
}

189
# return the car of the object (a cons cell)
190
sub car {
191
        my ($ob) = @_;
192
        return $ob->{car} // $Nil;
193 194
}

195
# return the cdr of the object (a cons cell)
196
sub cdr {
197
        my ($ob) = @_;
198 199 200
        return $ob->{cdr} // $Nil;
}

201 202
# return both the car and the cdr of the object (a cons cell); this is
# redundant, but saves us one function call
203 204 205 206 207
sub cxr {
        my ($ob) = @_;
        return ($ob->{car}, $ob->{cdr});
}

208 209 210 211 212 213 214 215 216 217 218 219 220
# return the car of the cdr of the object (a cons cell)
sub cadr {
        my ($ob) = @_;
        return $ob->{cdr}->{car} // $Nil;
}

# return the cdr of the cdr of the object (a cons cell)
sub cddr {
        my ($ob) = @_;
        return $ob->{cdr}->{cdr} // $Nil;
}

# replace the car of the cons
221 222 223 224 225
sub rplaca {
        my ($ob, $newcar) = @_;
        return $ob->{car} = $newcar;
}

226
# replace the car of the cons
227 228 229
sub rplacd {
        my ($ob, $newcdr) = @_;
        return $ob->{cdr} = $newcdr;
230 231
}

232 233 234
######## Functions
# a hash, too (surprise!): { type => 'expr|subr', spec => $is_special,
#                            func => $func, doc => $doc, env => $Env }
235

236 237 238
# create a new function of a Perl function or lambda, is-special flag,
# docstring, name (a symbol, for decoration in print only), and the function
# environment (optional (and currently unused)) or the current one
239
sub function {
240
        my ($func, $is_special, $doc, $name, $env) = @_;
241 242 243
        my $type;
        if (ref($func) eq 'CODE') {
                $type = 'subr';
244
        } elsif (ref($func) eq $n_Pair) {
245 246
                $type = 'expr';
        } else {
247
                error('function not subr or expr: %s', $func);
248
        }
249
        $env //= $Env;
250
        error('function: is_special undef: %s', $func)
251 252
            unless defined($is_special);
        return bless({ func => $func, type => $type, spec => $is_special,
253 254
                       doc => $doc // '', name => $name, env => $env },
                     $n_Function);
255 256
}

257 258
# return the name (symbol) of a function, the one it was defined with (but is
# not necessarily still bound to, for decorative purposes
259 260 261
sub function_name {
        my ($ob) = @_;
        return $ob->{name} // $Nil;
262
}
263

264
# return the type of a function, expr or subr
265 266 267 268 269
sub function_type {
        my ($ob) = @_;
        return $ob->{type};
}

270
# return the code of a function (subr or lambda)
271 272 273 274 275
sub function_code {
        my ($ob) = @_;
        return $ob->{func};
}

276 277
# return the parameter list of a function
sub function_params {
278 279
        my ($ob) = @_;
        return function_type($ob) eq 'expr' ? car($ob->{func}) : '';
Juergen Nickelsen's avatar
Juergen Nickelsen committed
280 281
}

282
# return the environment of a function
283 284 285 286 287
sub function_env {
        my ($ob) = @_;
        return $ob->{env};
}

288 289 290 291
# return the docstring of a function
sub function_documentation {
        my ($ob) = @_;
        return $ob->{doc};
292 293
}

294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309
######## Environments
# well, yes, a hash: { *parent-environment* => $parent, var1 => ... }
# the root environment's parent is $Nil
#
# if we put the symbols themselves into the hash, they are converted to strings
# of the form "Symbol=HASH(0x7f8f89a64030)", so we cannot use keys() to iterate
# over them; instead we put the symbol names as strings into the hash, so we can
# iterate over these and intern() ourselves back to the symbol
#
# in a previous version, each environment held a level counter, a name, and a
# reference to itself, but this came at some performance cost, so out again it
# went

# return the current environment (for a Builtin)
sub the_environment {
        return $Env;
310 311
}

312 313 314 315 316
# create a new environment with specified parent, needed separately from
# enter_environment() to create the root environment
sub new_environment {
        my ($parent) = @_;
        return bless({ $n_parentenv => $parent }, $n_Environment);
317 318
}

319 320 321 322 323 324 325 326 327 328
# be called for a lambda or let etc., creates a new environment with the
# previous (let/let*) or explicitly specified (lambda) environment as the parent
# and sets this as the current environment; returns the previous environment to
# be saved for the benefit of backto_environment()
sub enter_environment {
        my ($parent) = @_;
        my $newenv = new_environment($parent // $Env);
        my $save_env = $Env;
        $Env = $newenv;
        return $save_env;
329 330
}

331 332 333 334 335
# ends the current environment and goes back to the previously saved one (end of
# let/let*/dolist/lambda context)
sub backto_environment {
        $Env = $_[0];
        # warn("back to environment ", &$f_Princs($Env));
336 337
}

338 339 340 341 342 343 344 345 346 347 348
# return a list of the symbols bound as variables in the current environment;
# with optional $noparents, only in the actual current environment without its
# parents
sub env_vars {
        my ($env, $noparents) = @_;
        my %vars = ();
        for ( ; $env != $Nil; $env = $env->{$n_parentenv}) {
                @vars{keys(%$env)} = 1;
                last if $noparents;
        }
        return map { intern($_) } keys(%vars);
349 350
}

351
######## Predicates
352

353
sub is_nil {
354
        my ($ob) = @_;
355 356 357 358 359
        # we may compare directly with $Nil only once we *know* this is not a
        # string, as that would trigger a Perl error
        
        return $T if symbolp($ob) && $ob == $Nil;
        return 0;
360 361
}

362
sub is_t {
363
        my ($ob) = @_;
364 365
        return $T if symbolp($ob) && $ob == $T;
        return 0;
366 367
}

368
######## Type function and predicates
369

370
# return the (our) type name for the object
371
sub type_of {
372
        my ($ob) = @_;
373 374
        return "undef" unless defined($ob);
        return ref($ob) || "scalar";
375 376
}

377
# return true iff the object is a list (includes nil)
378 379
sub listp {
        my ($ob) = @_;
380
        return consp($ob) || is_nil($ob);
381 382
}

383
# return true iff the object is a symbol
384 385
sub symbolp {
        my ($ob) = @_;
386
        return ref($ob) eq $n_Symbol;
387 388
}

389
# return true iff the object is an environment
390 391 392 393 394
sub environmentp {
        my ($ob) = @_;
        return ref($ob) eq $n_Environment;
}

395
# return true iff the object is a function
396 397
sub functionp {
        my ($ob) = @_;
398
        return ref($ob) eq $n_Function;
399 400
}

401
# return true iff the object is a special form
402 403 404 405 406
sub specialp {
        my ($ob) = @_;
        return functionp($ob) && $ob->{spec};
}

407
# return true iff the object is a number
408 409 410 411 412
sub numberp {
        my ($ob) = @_;
        return ref($ob) eq "" && looks_like_number($ob);
}

413
# return true iff the object is a string
414 415
sub stringp {
        my ($ob) = @_;
416
        return ref($ob) eq ""; #  && !looks_like_number($ob)
417 418
}

419
# return true iff the object is a pair
420 421
sub consp {
        my ($ob) = @_;
422
        return ref($ob) eq $n_Pair;
423 424
}

425
######## Initialization
426 427
# we do a lot of Global's initialization here, because we need intern() and
# defvar() and want to keep cycles out of the dependency graph
428

429
sub init {
430

431 432 433 434 435 436 437
        $Lambda = intern("lambda");
        $andRest = intern("&rest");
        $andOptional = intern("&optional");
        $special = intern("special");
        $builtin = intern("builtin");
        $function = intern($n_function);
        $root_environment = intern($n_root_environment);
438

439 440 441 442 443 444
        $t_Symbol = intern("symbol");
        $t_String = intern("string");
        $t_Number = intern("number");
        $t_Pair   = intern("pair");
        $t_Function = intern("function");

445 446 447 448 449
        $Nil = intern("nil");           # needed early for parent of $root_Env
        $T = intern("t");               # needed early for is_nil()

        # initialize the root environment
        $root_Env = new_environment($Nil);
450 451
        $Env = $root_Env;
        $root_Env->{$n_env_name} = 'root_Env';
452

453 454
        # only now we can begin to set variable values
        defvar($root_environment, $root_Env);
455

456 457
        defvar($Nil, $Nil);
        defvar($T, $T);
458
}
459

460
1;