lisp/lisp.3

Raw file
Back to index

  1
  2
  3
  4
  5
  6
  7
  8
  9
 10
 11
 12
 13
 14
 15
 16
 17
 18
 19
 20
 21
 22
 23
 24
 25
 26
 27
 28
 29
 30
 31
 32
 33
 34
 35
 36
 37
 38
 39
 40
 41
 42
 43
 44
 45
 46
 47
 48
 49
 50
 51
 52
 53
 54
 55
 56
 57
 58
 59
 60
 61
 62
 63
 64
 65
 66
 67
 68
 69
 70
 71
 72
 73
 74
 75
 76
 77
 78
 79
 80
 81
 82
 83
 84
 85
 86
 87
 88
 89
 90
 91
 92
 93
 94
 95
 96
 97
 98
 99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
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
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
PACKET lisp heap maintenance                        (* Autor: J.Durchholz *) 
                                                    (* Datum: 09.05.1984  *) 
    DEFINES                                         (* Version 1.7.2      *) 
                                                    (* Testhilfe          *) 
  create lisp system,                  (* hey, 02.3.83 : 121,334,542,732 *) 
  dump oblist: 
 
 
PROC create lisp system (FILE VAR f, DATASPACE CONST new heap): 
  initialize lisp system (new heap); 
  input (f); 
  WHILE NOT eof (f) REP 
    TEXT VAR name; 
    get (f, name); 
    SYM CONST s :: new atom (name); 
    get (f, name); 
    SYM CONST property name :: new atom (name); 
    IF NOT null (property name) THEN 
      SYM VAR property; 
      get (f, property); 
      add property (s, property name, property) 
    FI 
  PER 
END PROC create lisp system; 
 
 
PROC dump oblist (FILE VAR f): 
  begin oblist dump; 
  REP 
    SYM CONST actual atom :: next atom; 
    put line (f, name (actual atom)); 
    dump property list 
  UNTIL null (actual atom) PER. 
 
dump property list: 
  begin property list dump (actual atom); 
  REP 
    SYM VAR id, value; 
    next property (id, value); 
    write (f, "  "); 
    write (f, name (id)); 
    write (f, " "); 
    write (f, name (value)); 
    line (f) 
  UNTIL null (id) AND null (value) PER. 
 
END PROC dump oblist; 
 
 
PROC dump oblist: 
  begin oblist dump; 
  REP 
    SYM CONST actual atom :: next atom; 
    put line (name (actual atom)); 
    dump property list 
  UNTIL null (actual atom) PER. 
 
dump property list: 
  begin property list dump (actual atom); 
  REP 
    SYM VAR id, value; 
    next property (id, value); 
    out ("  "); 
    out (name (id)); 
    out (" "); 
    put line (name (value)); 
  UNTIL null (id) AND null (value) PER. 
 
END PROC dump oblist; 
 
 
END PACKET lisp heap maintenance; 
 
 
 
PACKET lisp interpreter                             (* Autor: J.Durchholz *) 
                                                    (* Datum: 27.12.1982  *) 
    DEFINES                                         (* Version 3.1.7      *) 
  evalquote,
  apply, 
  eval, 
  try: 
 
 
(* SYM-objects used by the interpreter. They all point to constant structure
 within the heap. As their address may change during garbage collection,
 it must be possible to correct the references to them made by the
 SYM-objects. That is the reason why they are declared VAR instead of CONST*)
SYM VAR lambda constant, 
        label constant, 
        quote constant, 
        function constant, 
        indefinite constant, 
        apval constant, 
        true constant, 
        false constant; 
 
SYM VAR errors; 
BOOL VAR trace :: FALSE; 
 
PROC initialize constants: 
  lambda constant := new atom ("LAMBDA"); 
  label constant := new atom ("LABEL"); 
  quote constant := new atom ("QUOTE"); 
  function constant := new atom ("FUNCTION"); 
  indefinite constant := new atom ("INDEFINITE"); 
  apval constant := new atom ("APVAL"); 
  true constant := new atom ("T"); 
  false constant := new atom ("F"); 
  errors := new atom ("ERRORS") 
END PROC initialize constants; 
 
 
SYM PROC evalquote (SYM CONST expr):     (*hey*)
  enable stop; 
  initialize constants; 
  x apply ( head (expr), quote (tail (expr)), nil )
END PROC evalquote;
 
 
SYM PROC quote (SYM CONST x):
  IF eq (x,nil) THEN nil
  ELSE set head (x, new head); set tail (x, quote (tail(x))); x
  FI .
new head:
  cons (quote constant, cons (head(x), nil) )
END PROC quote;
 
 
SYM PROC apply (SYM CONST function, argument list, alist): 
  enable stop; 
  initialize constants; 
  x apply (function, argument list, alist) 
END PROC apply; 
 
 
SYM PROC x apply (SYM CONST function, argument list, alist): 
  IF trace THEN line;
    put ("a p p l y :"); put (function); line;
    put ("arguments :"); put (argument list); line;
  FI;
  SYM VAR new alist; 
  initialize for alist insertion; 
  reduce actual fn to lambda expression; 
  insert parameter evaluated argument pairs in reversed order in new alist; 
  function body evaluation. 
 
reduce actual fn to lambda expression: 
  SYM VAR actual fn :: function; 
  REP 
    IF is named atom (actual fn) THEN 
      get function from property list of actual fn 
                                           or from functional alist entry 
    ELIF atom (actual fn) THEN 
      error stop ("Eine Funktion darf kein unbenanntes Atom sein") 
    ELSE 
      IF eq (head (actual fn), lambda constant) THEN 
        LEAVE reduce actual fn to lambda expression 
      ELIF eq (head (actual fn), label constant) THEN 
        get function from label expression and update alist 
      ELSE 
        error stop ("Funktion ist weder Atom noch LAMBDA-/LABEL-Ausdruck") 
      FI 
    FI 
  PER. 
 
get function from property list of actual fn or from functional alist entry: 
  IF property exists (actual fn, function constant) THEN 
    get function from property list of actual fn 
  ELSE 
    get function from functional alist entry 
  FI. 
 
get function from property list of actual fn: 
  actual fn := property (actual fn, function constant). 
 
get function from functional alist entry: 
  SYM VAR actual alist entry; 
  begin alist retrieval; 
  REP 
    IF end of alist THEN 
      error stop ("Die Funktion " + name (actual fn) + 
                  " ist nicht definiert") 
    FI; 
    search for next functional alist entry; 
  UNTIL eq (head (actual functional alist entry), actual fn) PER; 
  actual fn := tail (actual functional alist entry). 
 
get function from label expression and update alist: 
  actual fn := tail (actual fn); 
  IF atom (actual fn) COR 
     (NOT atom (head (actual fn)) OR atom (tail (actual fn))) COR 
     NOT null (tail (tail (actual fn)))                           THEN 
    error stop ("Ungueltiger LABEL-Ausdruck") 
  FI; 
  SYM VAR new alist entry; 
  prepare new functional alist entry; 
  set head (new alist entry, head (actual fn)); 
  actual fn := head (tail (actual fn)); 
  set tail (new alist entry, actual fn). 
 
insert parameter evaluated argument pairs in reversed order in new alist: 
  actual fn := tail (actual fn); 
  IF atom (actual fn) THEN 
    error stop ("Ungueltiger LAMBDA-Ausdruck") 
  FI; 
  SYM VAR parameter list rest :: head (actual fn), 
          argument list rest :: argument list; 
  actual fn := tail (actual fn); 
  WHILE NOT null (parameter list rest) REP 
    add next parameter argument pair to alist 
  PER; 
  check wether no arguments are left over. 
 
add next parameter argument pair to alist: 
  IF atom (parameter list rest) THEN 
    error stop ("Parameterliste endet falsch") 
  FI; 
  SYM VAR param pointer :: head (parameter list rest); 
  parameter list rest := tail (parameter list rest); 
  IF is named atom (param pointer) AND NOT null (param pointer) THEN 
    add parameter evaluated argument pair to alist; 
    advance argument list rest 
  ELIF atom (param pointer) THEN 
    error stop ("Unbenannte Atome und NIL koennen nicht Parameter sein") 
  ELSE 
    IF eq (head (param pointer), indefinite constant) THEN 
      check wether is last param; 
      advance param pointer; 
      IF eq (head (param pointer), quote constant) THEN 
        advance param pointer; 
        move param pointer to parameter; 
        add parameter indefinite quoted argument pair to alist 
      ELSE 
        move param pointer to parameter; 
        add parameter indefinite evaluated argument pair to alist 
      FI; 
      argument list rest := nil 
    ELIF eq (head (param pointer), quote constant) THEN 
      advance param pointer; 
      move param pointer to parameter; 
      add parameter quoted argument pair to alist; 
      advance argument list rest 
    ELIF eq (head (param pointer), function constant) THEN 
      advance param pointer; 
      move param pointer to parameter; 
      add parameter functional argument pair to alist; 
      advance argument list rest 
    ELSE 
      error stop ("Ungueltiger Parameter") 
    FI 
  FI. 
 
advance param pointer: 
  param pointer := tail (param pointer); 
  IF atom (param pointer) THEN 
    error stop ("Ungueltiger Parameter") 
  FI. 
 
move param pointer to parameter: 
  IF NOT null (tail (param pointer)) THEN 
    error stop ("Ungueltiger Parameter") 
  FI; 
  param pointer := head (param pointer); 
  IF NOT atom (param pointer) OR null (param pointer) THEN 
    error stop ("Unbenannte Atome und NIL koennen nicht Parameter sein") 
  FI. 
 
advance argument list rest: 
  argument list rest := tail (argument list rest). 
 
add parameter evaluated argument pair to alist: 
  prepare new alist entry; 
  set head (new alist entry, param pointer); 
  set tail (new alist entry, x eval (actual argument, alist)). 
 
check wether is last param: 
  IF NOT null (parameter list rest) THEN 
    error stop ("Ein INDEFINITE-Parameter muss der letzte sein") 
  FI. 
 
add parameter indefinite quoted argument pair to alist: 
  prepare new alist entry; 
  set head (new alist entry, param pointer); 
  set tail (new alist entry, argument list rest); 
  WHILE NOT atom (argument list rest) REP 
    argument list rest := tail (argument list rest) 
  PER; 
  IF NOT null (argument list rest) THEN 
    error stop ("Argumentliste endet falsch") 
  FI. 
 
add parameter indefinite evaluated argument pair to alist: 
  prepare new alist entry; 
  set head (new alist entry, param pointer); 
  last evaluated argument := new alist entry; 
  WHILE NOT atom (argument list rest) REP 
    set tail (last evaluated argument, 
              cons (x eval (head (argument list rest), alist), nil)); 
    last evaluated argument := tail (last evaluated argument); 
    advance argument list rest 
  PER; 
  IF NOT null (argument list rest) THEN 
    error stop ("Argumentliste endet falsch") 
  FI. 
 
last evaluated argument: 
  param pointer. 
(* The value of param pointer is not used further, so the *) 
(* variable can be "reused" in this manner. *) 
 
add parameter quoted argument pair to alist: 
  prepare new alist entry; 
  set head (new alist entry, param pointer); 
  set tail (new alist entry, actual argument). 
 
add parameter functional argument pair to alist: 
  prepare new functional alist entry; 
  set head (new alist entry, param pointer); 
  set tail (new alist entry, actual argument). 
 
actual argument: 
  IF atom (argument list rest) THEN 
    IF null (argument list rest) THEN 
      error stop ("Zuwenig Argumente") 
    ELSE 
      error stop ("Argumentliste endet falsch") 
    FI 
  FI; 
  head (argument list rest). 
 
check wether no arguments are left over: 
  IF NOT null (argument list rest) THEN 
    error stop ("Zuviele Argumente") 
  FI. 
 
function body evaluation: 
  IF is int pair (actual fn) THEN 
    predefined function evaluation 
  ELIF atom (actual fn) COR NOT null (tail (actual fn)) THEN 
    error stop ("Ungueltiger LAMBDA-Ausdruck"); nil 
  ELSE 
    x eval (head (actual fn), new alist) 
  FI. 
 
predefined function evaluation: 
  SELECT int 1 (actual fn) OF 
    CASE 0: call eval cond 
    CASE 1: call begin oblist dump 
    CASE 2: call next atom 
    CASE 3: call add property 
    CASE 4: call alter property 
    CASE 5: call delete property 
    CASE 6: call property exists 
    CASE 7: call property 
    CASE 8: call add flag 
    CASE 9: call flag 
    CASE 10: call delete flag 
    CASE 11: call begin property list dump 
    CASE 12: call next property 
    CASE 13: call apply 
    CASE 14: call eval 
    CASE 15: call try 
    CASE 16: give association list 
    CASE 17: call error stop 
    CASE 18: call head 
    CASE 19: call set head 
    CASE 20: call tail 
    CASE 21: call set tail 
    CASE 22: call cons 
    CASE 23: call eq 
    CASE 24: call get sym 
    CASE 25: call put sym 
    CASE 26: call null 
    CASE 27: call is atom 
    CASE 28: call is named atom 
    CASE 29: call get named atom 
    CASE 30: call put named atom 
    CASE 31: call is text 
    CASE 32: call get text 
    CASE 33: call put text 
    CASE 34: call is character 
    CASE 35: call get character 
    CASE 36: call put character 
    CASE 37: call is int 
    CASE 38: call get int 
    CASE 39: call put int 
    CASE 40: call sum 
    CASE 41: call difference 
    CASE 42: call product 
    CASE 43: call quotient 
    CASE 44: call remainder
    CASE 45: call equal 
    CASE 46: call trace
    CASE 47: call define
    CASE 48: call set
    OTHERWISE error stop("Es gibt (noch) keine LISP-Funktion mit der Nummer" 
                          + text (int 1 (actual fn)) ); nil 
  END SELECT. 
 
call eval cond: 
  x eval condition (arg 1, alist). 
 
call begin oblist dump: 
  begin oblist dump; nil. 
 
call next atom: 
  next atom. 
 
call add property: 
  add property (arg 3, arg 2, arg 1); arg 1. 
 
call alter property: 
  alter property (arg 3, arg 2, arg 1); arg 1. 
 
call delete property: 
  delete property (arg 2, arg 1); nil. 
 
call property exists: 
  IF property exists(arg 2,arg 1) THEN true constant ELSE false constant FI. 
 
call property: 
  property (arg 2, arg 1). 
 
call add flag: 
  add flag (arg 2, arg 1); nil. 
 
call flag: 
  IF flag (arg 2, arg 1) THEN true constant ELSE false constant FI. 
 
call delete flag: 
  delete flag (arg 2, arg 1); nil. 
 
call begin property list dump: 
  begin property list dump (arg 1); nil. 
 
call next property: 
  SYM VAR s1, s2; next property (s1, s2); cons (s1, s2). 
 
call apply: 
  x apply (arg 3, arg 2, arg 1). 
 
call eval: 
  x eval (arg 2, arg 1). 
 
call try: 
  x try (arg 4, arg 3, arg 2, arg 1). 
 
give association list: 
  alist. 
 
call error stop: 
  error stop (text (arg 1)); nil. 
 
call head: 
  head (arg 1). 
 
call set head: 
  set head (arg 2, arg 1); arg 2. 
 
call tail: 
  tail (arg 1). 
 
call set tail: 
  set tail (arg 2, arg 1); arg 2. 
 
call cons: 
  cons (arg 2, arg 1). 
 
call eq: 
  IF eq (arg 2, arg 1) THEN true constant ELSE false constant FI. 
 
call get sym: 
  get (s1); s1. 
 
call put sym: 
  put (arg 1); arg 1. 
 
call null: 
  IF null (arg 1) THEN true constant ELSE false constant FI. 
 
call is atom: 
  IF atom (arg 1) THEN true constant ELSE false constant FI. 
 
call is named atom: 
  IF is named atom (arg 1) THEN true constant ELSE false constant FI. 
 
call get named atom: 
  TEXT VAR t; get (t); new atom (t). 
 
call put named atom: 
  put (name (arg 1)); arg 1. 
 
call is text: 
  IF is text (arg 1) THEN true constant ELSE false constant FI. 
 
call get text: 
  get (t); sym (t). 
 
call put text: 
  put (text (arg 1)); arg 1. 
 
call is character: 
  IF is character (arg 1) THEN true constant ELSE false constant FI. 
 
call get character: 
  inchar (t); sym character (code (t)). 
 
call put character: 
  out (code (character (arg 1))); arg 1. 
 
call is int: 
  IF is int pair (arg 1) THEN true constant ELSE false constant FI. 
 
call get int: 
  INT VAR i; get (i); sym (i, -1). 
 
call put int: 
  put (int 1 (arg 1)); arg 1. 
 
call sum: 
  sum (arg 1). 
 
call difference: 
  difference (arg 2, arg 1). 
 
call product: 
  product (arg 1). 
 
call quotient: 
  quotient (arg 2, arg 1). 
 
call remainder:
  remainder(arg 2, arg 1). 
 
call equal:
  IF equal (arg 2, arg 1) THEN true constant ELSE false constant FI.
 
call trace:
  trace := NOT trace;
  IF trace THEN true constant ELSE false constant FI . 
 
call define:     (*hey*) 
  define (arg 1) . 
 
call set:         (*hey*) 
  add property (new atom ( name (arg 2)), apval constant, arg 1); arg 1 . 
 
arg 1: 
  tail (head (new alist)). 
 
arg 2: 
  tail (head (tail (new alist))). 
 
arg 3: 
  tail (head (tail (tail (new alist)))). 
 
arg 4: 
  tail (head (tail (tail (tail (new alist))))). 
 
END PROC x apply; 
 
SYM PROC define (SYM CONST x):   (*hey*) 
  IF   eq (x, nil) THEN nil 
  ELSE add property (new atom (name (head (head (x)))), 
                     function constant, tail (head (x)) ); 
       cons (head (head (x)), define (tail (x)) ) 
  FI . 
END PROC define; 
 
SYM VAR old alist :: nil;
 
SYM PROC eval (SYM CONST expression, alist): 
  enable stop; 
  initialize constants; 
  x eval (expression, alist) 
END PROC eval; 
 
 
SYM PROC x eval (SYM CONST expression, alist):   (*hey*)
  IF trace THEN line;
    put ("e v a l   :"); put (expression); line;
    IF NOT equal (alist, old alist) THEN
    put ("bindings  :"); old alist := alist; put (alist); line FI
  FI;
  IF atom (expression) THEN 
    IF is named atom (expression) THEN 
      value from property list of expression or from alist entry 
    ELSE 
      expression 
    FI 
  ELSE 
    x apply (head (expression), tail (expression), alist) 
  FI. 
 
value from property list of expression or from alist entry: 
  IF property exists (expression, apval constant) THEN 
    value from property list of expression 
  ELSE 
    value from alist entry 
  FI. 
 
value from property list of expression: 
  property (expression, apval constant). 
 
value from alist entry: 
  SYM VAR actual alist entry; 
  begin alist retrieval; 
  REP 
    IF end of alist THEN 
      error stop ("Das Atom " + name (expression) + " hat keinen Wert") 
    FI; 
    search for next alist entry 
  UNTIL eq (head (actual alist entry), expression) PER; 
  tail (actual alist entry). 
 
END PROC x eval; 
 
 
SYM PROC try (SYM CONST expression list, alist, 
                        error output, break possible): 
  enable stop; 
  initialize constants; 
  x try (expression list, alist, error output, break possible) 
END PROC try; 
 
 
SYM PROC x try (SYM CONST expression list, alist, 
                          error output, break possible): 
  BOOL CONST output :: bool (error output), 
             halt enabled :: bool (break possible); 
  SYM VAR expr list rest :: expression list; 
  REP 
    IF null (expr list rest) THEN 
      LEAVE x try WITH nil 
    ELIF atom (expr list rest) THEN 
      error stop ("Ausdrucksliste fuer 'try' endet falsch") 
    ELSE 
      try evaluation of actual expression 
    FI; 
    expr list rest := tail (expr list rest) 
  PER; 
  nil. 
 
try evaluation of actual expression: 
  disable stop; 
  SYM VAR result :: x eval (head (expr list rest), alist); 
  IF is error THEN 
    IF error message = "halt from terminal" AND halt enabled THEN 
      enable stop 
    ELIF output THEN 
      put error 
    FI; 
    add property (errors, apval constant, sym (error message)); 
    clear error 
  ELSE 
    LEAVE x try WITH result 
  FI; 
  enable stop. 
 
END PROC x try; 
 
 
SYM PROC x eval condition (SYM CONST pair list, alist): 
  enable stop; 
  SYM VAR cond pair list rest :: pair list; 
  REP 
    IF atom (cond pair list rest) THEN 
      error stop ("Keine 'T'-Bedingung in bedingtem Ausdruck gefunden") 
    FI; 
    check wether is correct pair; 
    IF true condition found THEN 
      LEAVE x eval condition WITH x eval (head (tail (actual pair)), alist) 
    FI; 
    cond pair list rest := tail (cond pair list rest) 
  PER; 
  nil. 
 
check wether is correct pair: 
  IF atom (actual pair) COR 
     atom (tail (actual pair)) COR 
     NOT null (tail (tail (actual pair))) THEN 
    error stop ("Ungueltiges Paar im bedingten Ausdruck") 
  FI. 
 
true condition found: 
  bool (x eval (head (actual pair), alist)). 
 
actual pair: 
  head (cond pair list rest). 
 
END PROC x eval condition; 
 
 
BOOL PROC bool (SYM CONST sym): 
  IF eq (sym, true constant) THEN 
    TRUE 
  ELIF eq (sym, false constant) THEN 
    FALSE 
  ELSE 
    error stop ("'T' oder 'F' erwartet"); TRUE 
  FI 
END PROC bool; 
 
 
(******* a-list handling refinements used in 'x apply' and 'x eval' *******) 
 
(* declared within 'x apply' and 'x eval': 'actual alist entry'           *) 
 
. 
 
initialize for alist insertion: 
  new alist := alist. 
 
begin alist retrieval: 
  SYM VAR actual alist pos :: alist. 
 
search for next alist entry: 
  WHILE NOT end of alist REP 
    IF atom (actual alist pos) THEN 
      error stop ("Bindeliste endet falsch") 
    FI; 
    actual alist entry := head (actual alist pos); 
    actual alist pos := tail (actual alist pos); 
  UNTIL is non functional alist entry PER. 
 
is non functional alist entry: 
  NOT is functional alist entry. 
 
search for next functional alist entry: 
  WHILE NOT end of alist REP 
    IF atom (actual alist pos) THEN 
      error stop ("Bindeliste endet falsch") 
    FI; 
    actual alist entry := head (actual alist pos); 
    actual alist pos := tail (actual alist pos); 
  UNTIL is functional alist entry PER; 
  actual alist entry := tail (actual alist entry). 
 
is functional alist entry: 
  check wether is alist entry; 
  null (head (actual alist entry)). 
 
check wether is alist entry: 
  IF atom (actual alist entry) THEN 
    error stop ("Bindelisteneintrag ist kein Paar") 
  FI. 
 
end of alist: 
  null (actual alist pos). 
 
actual functional alist entry: 
  actual alist entry. 
 
prepare new alist entry: 
  new alist := cons (cons (nil, nil), new alist); 
  new alist entry := head (new alist). 
 
prepare new functional alist entry: 
  new alist := cons (cons (nil, cons (nil, nil)), new alist); 
  new alist entry := tail (head (new alist)). 
 
 
END PACKET lisp interpreter;