1"====================================================================== 2| 3| Lisp interpreter written in Smalltalk 4| 5| 6 ======================================================================" 7 8 9"====================================================================== 10| 11| Written by Aoki Atsushi and Nishihara Satoshi. 12| Modified by Paolo Bonzini (removed GUI and compiler for subset of Smalltalk). 13| 14| This file is part of GNU Smalltalk. 15| 16| GNU Smalltalk is free software; you can redistribute it and/or modify it 17| under the terms of the GNU General Public License as published by the Free 18| Software Foundation; either version 2, or (at your option) any later version. 19| 20| GNU Smalltalk is distributed in the hope that it will be useful, but WITHOUT 21| ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS 22| FOR A PARTICULAR PURPOSE. See the GNU General Public License for more 23| details. 24| 25| You should have received a copy of the GNU General Public License along with 26| GNU Smalltalk; see the file COPYING. If not, write to the Free Software 27| Foundation, 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. 28| 29 ======================================================================" 30 31SequenceableCollection subclass: #LispList 32 instanceVariableNames: '' 33 classVariableNames: '' 34 poolDictionaries: '' 35 category: 'Examples-Lisp'! 36 37LispList subclass: #LispCons 38 instanceVariableNames: 'head tail ' 39 classVariableNames: 'VerticalLevel HorizontalLevel ' 40 poolDictionaries: '' 41 category: 'Examples-Lisp'! 42 43LispList subclass: #LispNil 44 instanceVariableNames: '' 45 classVariableNames: '' 46 poolDictionaries: '' 47 category: 'Examples-Lisp'! 48 49Object subclass: #LispScanner 50 instanceVariableNames: 'source mark token tokenType failBlock ' 51 classVariableNames: 'ScanningTable ' 52 poolDictionaries: '' 53 category: 'Examples-Lisp'! 54 55LispScanner subclass: #LispParser 56 instanceVariableNames: 'prevMark prevToken prevTokenType ' 57 classVariableNames: '' 58 poolDictionaries: '' 59 category: 'Examples-Lisp'! 60 61Object subclass: #LispTable 62 instanceVariableNames: 'properties ' 63 classVariableNames: '' 64 poolDictionaries: '' 65 category: 'Examples-Lisp'! 66 67Object subclass: #LispInterpreter 68 instanceVariableNames: 'lispTable bindStack failBlock textValue textCollector ' 69 classVariableNames: '' 70 poolDictionaries: '' 71 category: 'Examples-Lisp'! 72 73 74 75!LispList class methodsFor: 'copyright'! 76 77copyright 78 ^'Copyright (C) 1995-1998 AOKI Atsushi, All Rights Reserved.'! 79 80system 81 ^'Goodies'! 82 83version 84 ^'003'! ! 85 86!LispList class methodsFor: 'instance creation'! 87 88cell 89 ^self subclassResponsibility! 90 91head: headObject 92 ^self subclassResponsibility! 93 94head: headObject tail: tailObject 95 ^self subclassResponsibility! 96 97list: anArray 98 "LispCons list: #(1 2 3 4)" 99 100 | size list | 101 size := anArray size. 102 list := self null. 103 size 104 to: 1 105 by: -1 106 do: [:i | list := self head: (anArray at: i) 107 tail: list]. 108 ^list! 109 110new: anInteger 111 "LispCons new: 5" 112 113 | newList | 114 newList := self null. 115 anInteger timesRepeat: [newList := self head: self null tail: newList]. 116 ^newList! 117 118null 119 ^self subclassResponsibility! 120 121with: anObject 122 "LispCons with: 1" 123 124 ^self head: anObject! 125 126with: firstObject with: secondObject 127 "LispCons with: 1 with: 2" 128 129 ^self head: firstObject tail: (self with: secondObject)! 130 131with: firstObject with: secondObject with: thirdObject 132 "LispCons with: 1 with: 2 with: 3" 133 134 ^self head: firstObject tail: (self with: secondObject with: thirdObject)! 135 136with: firstObject with: secondObject with: thirdObject with: fourthObject 137 "LispCons with: 1 with: 2 with: 3 with: 4" 138 139 ^self head: firstObject tail: (self 140 with: secondObject 141 with: thirdObject 142 with: fourthObject)! ! 143 144!LispList methodsFor: 'accessing'! 145 146at: indexInteger put: anObject 147 ^self subscriptOutOfBoundsError: indexInteger! 148 149size 150 | tally | 151 tally := 0. 152 self do: [:each | tally := tally + 1]. 153 ^tally! ! 154 155!LispList methodsFor: 'private'! 156 157subscriptOutOfBoundsError: index 158 ^self error: 'subscript out of bounds: ' , index printString! ! 159 160!LispList methodsFor: 'testing'! 161 162isCons 163 ^self null not! 164 165null 166 ^false! ! 167 168 169 170!LispCons class methodsFor: 'class initialization'! 171 172initialize 173 "LispCons initialize." 174 175 HorizontalLevel := VerticalLevel := nil! ! 176 177!LispCons class methodsFor: 'copyright'! 178 179copyright 180 ^'Copyright (C) 1995-1998 AOKI Atsushi, All Rights Reserved.'! 181 182system 183 ^'Goodies'! 184 185version 186 ^'003'! ! 187 188!LispCons class methodsFor: 'examples'! 189 190example1 191 "LispCons example1." 192 193 | list | 194 list := LispCons list: #(1 2 3 4 5 6 7 8 9 10 ). 195 Transcript nl; show: list printString. 196 ^list! 197 198example2 199 "LispCons example2." 200 201 | null list | 202 null := LispCons null. 203 list := LispCons list: #(1 2 ). 204 list := LispCons head: list tail: null. 205 list := LispCons head: list tail: null. 206 Transcript nl; show: list printString. 207 ^list! 208 209example3 210 "LispCons example3." 211 212 | x y z | 213 x := LispCons list: #(1 2 3 ). 214 y := LispCons list: #(4 5 6 ). 215 z := LispCons list: #(1 2 3 4 5 6 ). 216 Transcript nl; show: '(setq x ''(1 2 3)) => ' , x printString. 217 Transcript nl; show: '(setq y ''(4 5 6)) => ' , y printString. 218 Transcript nl; show: '(setq z ''(1 2 3 4 5 6)) => ' , z printString. 219 Transcript nl; show: '(append x y) => ' , (x append: y) printString. 220 Transcript nl; show: '(length z) => ' , z length printString. 221 Transcript nl; show: '(member 3 z) => ' , (z member: 3) printString. 222 Transcript nl; show: '(nth 4 z) => ' , (z nth: 4) printString. 223 ^z! 224 225example4 226 "LispCons example4." 227 228 | list | 229 list := LispCons list: #(1 2 ). 230 list := LispCons head: list tail: (LispCons list: #(3 4 )). 231 list := LispCons head: list tail: (LispCons list: #(5 6 )). 232 Transcript nl; show: list saveString. 233 ^list! 234 235example5 236 "LispCons example5." 237 238 | list | 239 list := LispCons loadFrom: ' 240 (PetriNet Aoki 241 (Place p1 p2 p3 p4 p5) 242 (Transition t1 t2 t3 t4 t5) 243 (InputFunction 244 (t1 p1 p2 p3 p4 p5) 245 (t2 . p4) 246 (t3 . p5)) 247 (OutputFunction 248 (t1 p1 p2 p3 p4 p5) 249 (t2 . p4) 250 (t3 . p5)) 251 (Marking {#(1 2 3 4 5)})))'. 252 Transcript nl; show: list saveString. 253 ^list! 254 255example6 256 "LispCons example6." 257 258 | list | 259 list := LispCons loadFrom: '(aaa bbb ccc)'. 260 Transcript nl; show: list saveString. 261 ^list! 262 263example7 264 "LispCons example7." 265 266 | list | 267 list := LispCons loadFrom: ' `(`(1 2 `3) . `4 ) '. 268 Transcript nl; show: list saveString. 269 ^list! ! 270 271!LispCons class methodsFor: 'instance creation'! 272 273cell 274 ^super new head: self null tail: self null! 275 276head: headObject 277 ^super new head: headObject tail: self null! 278 279head: headObject tail: tailObject 280 ^super new head: headObject tail: tailObject! 281 282list: anArray 283 | size list | 284 size := anArray size. 285 list := self null. 286 size 287 to: 1 288 by: -1 289 do: [:i | list := self head: (anArray at: i) 290 tail: list]. 291 ^list! 292 293loadFrom: aStream 294 "by nishis, 1998/04/19 07:51" 295 296 | list | 297 list := LispParser parse: aStream. 298 ^list! 299 300new 301 ^self cell! 302 303null 304 ^LispNil null! ! 305 306!LispCons class methodsFor: 'level accessing'! 307 308horizontalLevel 309 HorizontalLevel isNil ifTrue: [HorizontalLevel := 50]. 310 ^HorizontalLevel! 311 312horizontalLevel: anInteger 313 HorizontalLevel := anInteger! 314 315verticalLevel 316 VerticalLevel isNil ifTrue: [VerticalLevel := 10]. 317 ^VerticalLevel! 318 319verticalLevel: anInteger 320 VerticalLevel := anInteger! ! 321 322!LispCons class methodsFor: 'utilities'! 323 324classHierarchy: aClass 325 "LispCons classHierarchy: Number." 326 327 | theClass list | 328 aClass isMeta 329 ifTrue: [theClass := aClass soleInstance] 330 ifFalse: [theClass := aClass]. 331 list := self subclassHierarchy: theClass. 332 (theClass allSuperclasses select: [:each | each isMeta not]) 333 do: [:each | list := self head: each name tail: (self head: list tail: self null)]. 334 ^list! 335 336subclassHierarchy: aClass 337 "LispCons subclassHierarchy: Number." 338 339 | theClass list collection sub | 340 aClass isMeta 341 ifTrue: [theClass := aClass soleInstance] 342 ifFalse: [theClass := aClass]. 343 list := self null. 344 theClass subclasses isEmpty 345 ifFalse: 346 [collection := SortedCollection sortBlock: [:x :y | x name > y name]. 347 collection addAll: (theClass subclasses select: [:each | each isMeta not]). 348 collection 349 do: 350 [:each | 351 sub := self subclassHierarchy: each. 352 list := self head: sub tail: list]]. 353 ^self head: theClass name tail: list! 354 355superclassHierarchy: aClass 356 "LispCons superclassHierarchy: Number." 357 358 | theClass list | 359 aClass isMeta 360 ifTrue: [theClass := aClass soleInstance] 361 ifFalse: [theClass := aClass]. 362 list := self head: theClass name tail: self null. 363 (theClass allSuperclasses select: [:each | each isMeta not]) 364 do: [:each | list := self head: each name tail: (self head: list tail: self null)]. 365 ^list! ! 366 367!LispCons methodsFor: 'accessing'! 368 369at: indexInteger 370 | count | 371 count := 1. 372 self 373 mapcdr: 374 [:cdr | 375 indexInteger = count ifTrue: [^cdr head]. 376 count := count + 1]. 377 ^self subscriptOutOfBoundsError: indexInteger! 378 379at: indexInteger put: anObject 380 | count | 381 count := 1. 382 self 383 mapcdr: 384 [:cdr | 385 indexInteger = count ifTrue: [^cdr head: anObject]. 386 count := count + 1]. 387 ^self subscriptOutOfBoundsError: indexInteger! 388 389head 390 ^head! 391 392head: anObject 393 ^head := anObject! 394 395head: headObject tail: tailObject 396 self head: headObject. 397 self tail: tailObject! 398 399tail 400 ^tail! 401 402tail: anObject 403 ^tail := anObject! ! 404 405!LispCons methodsFor: 'adding'! 406 407add: newObject 408 ^self nconc: (self class head: newObject tail: self class null)! ! 409 410!LispCons methodsFor: 'enumerating'! 411 412collect: aBlock 413 | list result | 414 list := self. 415 result := self class null. 416 [list isKindOf: self class] 417 whileTrue: 418 [result := self class head: (aBlock value: list head) 419 tail: result. 420 list := list tail]. 421 ^result reverse! 422 423do: aBlock 424 | list | 425 list := self. 426 [list isKindOf: self class] 427 whileTrue: 428 [aBlock value: list head. 429 list := list tail]! ! 430 431!LispCons methodsFor: 'functions'! 432 433append: list 434 (tail isKindOf: self class) 435 ifFalse: [^self class head: head tail: list]. 436 ^self class head: head tail: (tail append: list)! 437 438last 439 | list | 440 list := self class head: nil tail: self. 441 self do: [:each | list := list tail]. 442 ^list! 443 444length 445 | count | 446 count := 0. 447 self do: [:each | count := count + 1]. 448 ^count! 449 450mapcdr: aBlock 451 | list | 452 list := self. 453 [list isKindOf: self class] 454 whileTrue: 455 [aBlock value: list. 456 list := list tail]! 457 458member: anObject 459 | list | 460 list := self. 461 self do: 462 [:each | 463 each = anObject ifTrue: [^list]. 464 list := list tail]. 465 ^self species null! 466 467memq: anObject 468 | list | 469 list := self. 470 self do: 471 [:each | 472 each == anObject ifTrue: [^list]. 473 list := list tail]. 474 ^self species null! 475 476nconc: list 477 self last rplacd: list! 478 479nth: nth 480 | count list | 481 nth <= 0 ifTrue: [^self species null]. 482 count := 1. 483 list := self. 484 list do: 485 [:each | 486 count >= nth ifTrue: [^each]. 487 count := count + 1]. 488 ^self species null! 489 490reverse 491 | list | 492 list := self class null. 493 self do: [:each | list := self class head: each tail: list]. 494 ^list! 495 496rplaca: anObject 497 self head: anObject! 498 499rplacd: anObject 500 self tail: anObject! ! 501 502!LispCons methodsFor: 'pretty printing'! 503 504ppOn: aStream 505 self 506 ppOn: aStream 507 list: self 508 position: 0. 509 aStream nl! 510 511ppOn: aStream list: list position: position 512 (list isKindOf: self class) 513 ifFalse: [^self ppOn: aStream object: list]. 514 (list head isKindOf: self class) not 515 ifTrue: 516 [aStream nextPutAll: '('. 517 self ppOn: aStream object: list head. 518 (list tail isKindOf: LispList) 519 ifTrue: [self 520 ppOn: aStream 521 tail: list tail 522 position: position + 1] 523 ifFalse: 524 [aStream nextPutAll: ' . '. 525 self ppOn: aStream object: list tail]. 526 aStream nextPutAll: ')'] 527 ifFalse: 528 [aStream nextPutAll: '('. 529 self 530 ppOn: aStream 531 list: list head 532 position: position + 1. 533 (list tail isKindOf: self class) 534 ifTrue: [(list tail head isKindOf: self class) 535 ifTrue: 536 [aStream nl. 537 self ppOn: aStream spaceAndTab: position. 538 self 539 ppOn: aStream 540 tail: list tail 541 position: position] 542 ifFalse: 543 [self ppOn: aStream space: 1. 544 self 545 ppOn: aStream 546 tail: list tail 547 position: position + 1]] 548 ifFalse: [(list tail isKindOf: LispList) 549 ifFalse: 550 [aStream nextPutAll: ' . '. 551 self ppOn: aStream object: list tail]]. 552 aStream nextPutAll: ')']! 553 554ppOn: aStream object: anObject 555 (anObject isKindOf: Symbol) 556 ifTrue: [^aStream nextPutAll: anObject asString]. 557 (anObject isKindOf: String) 558 ifTrue: 559 [aStream nextPutAll: '"'. 560 anObject 561 do: 562 [:char | 563 char = $" ifTrue: [aStream nextPut: $"]. 564 aStream nextPut: char]. 565 ^aStream nextPutAll: '"']. 566 (anObject isKindOf: Number) 567 ifTrue: [^anObject storeOn: aStream]. 568 (anObject isMemberOf: LispNil) 569 ifTrue: [^aStream nextPutAll: 'nil']. 570 aStream nextPutAll: '{'. 571 aStream nextPutAll: (anObject printString contractTo: 80). 572 aStream nextPutAll: '}'! 573 574ppOn: aStream space: anInteger 575 anInteger timesRepeat: [aStream nextPut: Character space]! 576 577ppOn: aStream spaceAndTab: anInteger 578 | tabs spaces | 579 tabs := anInteger // self tabStop. 580 spaces := anInteger \\ self tabStop. 581 tabs * (self tabStop // 4) timesRepeat: [aStream tab]. 582 spaces timesRepeat: [aStream space]! 583 584ppOn: aStream tail: list position: position 585 list null ifTrue: [^self]. 586 (list tail isKindOf: LispList) 587 ifTrue: [list tail null 588 ifTrue: 589 [self ppOn: aStream space: 1. 590 self 591 ppOn: aStream 592 list: list head 593 position: position + 1] 594 ifFalse: 595 [self ppOn: aStream space: 1. 596 self 597 ppOn: aStream 598 list: list head 599 position: position + 1. 600 aStream nl. 601 self ppOn: aStream spaceAndTab: position. 602 self 603 ppOn: aStream 604 tail: list tail 605 position: position]] 606 ifFalse: 607 [self ppOn: aStream space: 1. 608 self 609 ppOn: aStream 610 list: list head 611 position: position + 1. 612 aStream nextPutAll: ' . '. 613 self ppOn: aStream object: list tail]! 614 615ppString 616 | stream | 617 stream := WriteStream on: (String new: 20). 618 self ppOn: stream. 619 ^stream contents! ! 620 621!LispCons methodsFor: 'printing'! 622 623printOn: aStream 624 self printOn: aStream level: 0! 625 626printOn: aStream level: level 627 | verticalLevel | 628 verticalLevel := self class verticalLevel. 629 (verticalLevel ~= 0 and: [level >= verticalLevel]) 630 ifTrue: 631 [aStream nextPutAll: '( ... )'. 632 ^self]. 633 self null ifTrue: [^super printOn: aStream]. 634 aStream nextPutAll: '('. 635 (head isKindOf: self class) 636 ifTrue: [head printOn: aStream level: level + 1] 637 ifFalse: [self printOn: aStream object: head]. 638 (tail isKindOf: LispList) 639 ifTrue: [self 640 printOn: aStream 641 tail: tail 642 level: level] 643 ifFalse: 644 [aStream nextPutAll: ' . '. 645 self printOn: aStream object: tail. 646 ^aStream nextPutAll: ')']! 647 648printOn: aStream object: anObject 649 (anObject isKindOf: Symbol) 650 ifTrue: [^aStream nextPutAll: anObject asString]. 651 (anObject isKindOf: String) 652 ifTrue: 653 [aStream nextPutAll: '"'. 654 anObject 655 do: 656 [:char | 657 char = $" ifTrue: [aStream nextPut: $"]. 658 aStream nextPut: char]. 659 ^aStream nextPutAll: '"']. 660 (anObject isKindOf: Number) 661 ifTrue: [^anObject storeOn: aStream]. 662 (anObject isMemberOf: LispNil) 663 ifTrue: [^aStream nextPutAll: 'nil']. 664 aStream nextPutAll: '{'. 665 aStream nextPutAll: (anObject printString contractTo: 80). 666 aStream nextPutAll: '}'! 667 668printOn: aStream tail: cdr level: level 669 | tailPart count horizontalLevel | 670 cdr null ifTrue: [^aStream nextPutAll: ')']. 671 tailPart := cdr. 672 count := 1. 673 horizontalLevel := self class horizontalLevel. 674 tailPart do: 675 [:each | 676 (horizontalLevel ~= 0 and: [count >= horizontalLevel]) 677 ifTrue: 678 [aStream nextPutAll: ' ... )'. 679 ^self]. 680 aStream nextPutAll: ' '. 681 (each isKindOf: self class) 682 ifTrue: [tailPart head printOn: aStream level: level + 1] 683 ifFalse: [self printOn: aStream object: each]. 684 tailPart := tailPart tail. 685 count := count + 1]. 686 (tailPart isKindOf: LispList) 687 ifTrue: [aStream nextPutAll: ')'] 688 ifFalse: 689 [aStream nextPutAll: ' . '. 690 self printOn: aStream object: tailPart. 691 aStream nextPutAll: ')']! ! 692 693!LispCons methodsFor: 'private'! 694 695tabStop 696 ^8! ! 697 698!LispCons methodsFor: 'saving'! 699 700saveOn: aStream 701 self 702 saveOn: aStream 703 list: self 704 position: 0. 705 aStream nl! 706 707saveOn: aStream list: list position: position 708 | location length | 709 (list isKindOf: self class) 710 ifFalse: [^self saveOn: aStream object: list]. 711 (list head isKindOf: self class) not 712 ifTrue: 713 [aStream nextPutAll: '('. 714 location := aStream position. 715 self saveOn: aStream object: list head. 716 (list tail isKindOf: LispList) 717 ifTrue: 718 [length := aStream position - location min: 40. 719 length := 0. 720 self 721 saveOn: aStream 722 tail: list tail 723 position: position + 1 + length] 724 ifFalse: 725 [aStream nextPutAll: ' . '. 726 self saveOn: aStream object: list tail]. 727 aStream nextPutAll: ')'] 728 ifFalse: 729 [aStream nextPutAll: '('. 730 self 731 saveOn: aStream 732 list: list head 733 position: position + 1. 734 (list tail isKindOf: self class) 735 ifTrue: [(list tail head isKindOf: self class) 736 ifTrue: 737 [aStream nl. 738 self saveOn: aStream spaceAndTab: position. 739 self 740 saveOn: aStream 741 tail: list tail 742 position: position] 743 ifFalse: 744 [self saveOn: aStream space: 1. 745 self 746 saveOn: aStream 747 tail: list tail 748 position: position + 1]] 749 ifFalse: [(list tail isKindOf: LispList) 750 ifFalse: 751 [aStream nextPutAll: ' . '. 752 self saveOn: aStream object: list tail]]. 753 aStream nextPutAll: ')']! 754 755saveOn: aStream object: anObject 756 | string | 757 (anObject isKindOf: Symbol) 758 ifTrue: [^aStream nextPutAll: anObject asString]. 759 (anObject isKindOf: String) 760 ifTrue: 761 [aStream nextPutAll: '"'. 762 anObject 763 do: 764 [:char | 765 char = $" ifTrue: [aStream nextPut: $"]. 766 aStream nextPut: char]. 767 ^aStream nextPutAll: '"']. 768 (anObject isKindOf: Integer) 769 ifTrue: [^anObject storeOn: aStream]. 770 (anObject isKindOf: Float) 771 ifTrue: [^anObject storeOn: aStream]. 772 "(anObject isKindOf: Double) 773 ifTrue: [^anObject storeOn: aStream]." 774 (anObject isMemberOf: LispNil) 775 ifTrue: [^aStream nextPutAll: 'nil']. 776 aStream nextPutAll: '{'. 777 ((anObject isKindOf: Point) 778 or: [anObject isKindOf: Rectangle]) 779 ifTrue: [string := anObject printString] 780 ifFalse: [string := anObject storeString]. 781 aStream nextPutAll: string. 782 aStream nextPutAll: '}'! 783 784saveOn: aStream space: anInteger 785 anInteger timesRepeat: [aStream nextPut: Character space]! 786 787saveOn: aStream spaceAndTab: anInteger 788 | tabs spaces | 789 tabs := anInteger // self tabStop. 790 spaces := anInteger \\ self tabStop. 791 tabs timesRepeat: [aStream tab]. 792 spaces timesRepeat: [aStream space]! 793 794saveOn: aStream tail: list position: position 795 list null ifTrue: [^self]. 796 (list tail isKindOf: LispList) 797 ifTrue: [list tail null 798 ifTrue: 799 [self saveOn: aStream space: 1. 800 self 801 saveOn: aStream 802 list: list head 803 position: position + 1] 804 ifFalse: 805 [self saveOn: aStream space: 1. 806 self 807 saveOn: aStream 808 list: list head 809 position: position + 1. 810 aStream nl. 811 self saveOn: aStream spaceAndTab: position. 812 self 813 saveOn: aStream 814 tail: list tail 815 position: position]] 816 ifFalse: 817 [self saveOn: aStream space: 1. 818 self 819 saveOn: aStream 820 list: list head 821 position: position + 1. 822 aStream nextPutAll: ' . '. 823 self saveOn: aStream object: list tail]! 824 825saveString 826 | stream | 827 stream := WriteStream on: (String new: 20). 828 self saveOn: stream. 829 ^stream contents! ! 830 831!LispCons methodsFor: 'testing'! 832 833= anObject 834 (anObject isKindOf: self class) 835 ifFalse: [^false]. 836 self head = anObject head ifTrue: [^self tail = anObject tail]. 837 ^false! ! 838 839 840LispCons initialize! 841 842LispNil class instanceVariableNames: 'null '! 843 844!LispNil class methodsFor: 'class initialization'! 845 846initialize 847 "LispNil initialize." 848 849 self null! ! 850 851!LispNil class methodsFor: 'copyright'! 852 853copyright 854 ^'Copyright (C) 1995-1998 AOKI Atsushi, All Rights Reserved.'! 855 856system 857 ^'Goodies'! 858 859version 860 ^'003'! ! 861 862!LispNil class methodsFor: 'instance creation'! 863 864cell 865 ^LispCons cell! 866 867head: headObject 868 ^self shouldNotImplement! 869 870head: headObject tail: tailObject 871 ^self shouldNotImplement! 872 873new 874 ^self null! 875 876null 877 null isNil ifTrue: [null := super new]. 878 ^null! ! 879 880!LispNil methodsFor: 'accessing'! 881 882head 883 ^self! 884 885tail 886 ^self! ! 887 888!LispNil methodsFor: 'adding'! 889 890add: newObject 891 ^self shouldNotImplement! ! 892 893!LispNil methodsFor: 'enumerating'! 894 895do: aBlock 896 ^self! ! 897 898!LispNil methodsFor: 'functions'! 899 900append: list 901 ^list! 902 903length 904 ^0! 905 906mapcdr: aBlock 907 ^self! 908 909member: anObject 910 ^self! 911 912nconc: list 913 ^list! 914 915nth: nth 916 ^self! 917 918reverse 919 ^self! ! 920 921!LispNil methodsFor: 'pretty printing'! 922 923ppOn: aStream 924 aStream nextPutAll: 'nil'. 925 aStream nl! 926 927ppString 928 ^'nil\' withCRs! ! 929 930!LispNil methodsFor: 'printing'! 931 932printOn: aStream 933 aStream nextPutAll: 'nil'! ! 934 935!LispNil methodsFor: 'saving'! 936 937saveOn: aStream 938 aStream nextPutAll: 'nil'! 939 940saveString 941 ^'nil'! ! 942 943!LispNil methodsFor: 'testing'! 944 945null 946 ^true! ! 947 948 949LispNil initialize! 950 951!LispScanner class methodsFor: 'copyright'! 952 953copyright 954 ^'Copyright (C) 1995-1998 AOKI Atsushi, All Rights Reserved.'! 955 956system 957 ^'Goodies'! 958 959version 960 ^'003'! ! 961 962!LispScanner class methodsFor: 'initialize-release'! 963 964initialize 965 | newTable | 966 newTable := Array new: 256 withAll: #xBinary. 967 newTable atAll: #(9 10 11 12 13 32) put: #xDelimiter. 968 newTable atAll: ($0 asInteger to: $9 asInteger) put: #xDigit. 969 newTable atAll: ($A asInteger to: $Z asInteger) put: #xSymbol. 970 newTable atAll: ($a asInteger to: $z asInteger) put: #xSymbol. 971 128 to: 256 do: [:i | newTable at: i put: #xSymbol]. 972 newTable at: $' asInteger put: #quote. 973 newTable at: $" asInteger put: #xDoubleQuote. 974 newTable at: ${ asInteger put: #xBrace. 975 newTable at: $+ asInteger put: #xSign. 976 newTable at: $- asInteger put: #xSign. 977 newTable at: $< asInteger put: #xSymbol. 978 newTable at: $> asInteger put: #xSymbol. 979 newTable at: $= asInteger put: #xSymbol. 980 newTable at: $~ asInteger put: #xSymbol. 981 newTable at: $* asInteger put: #xSymbol. 982 newTable at: $/ asInteger put: #xSymbol. 983 newTable at: $_ asInteger put: #xSymbol. 984 newTable at: $: asInteger put: #xSymbol. 985 newTable at: $, asInteger put: #xSymbol. 986 newTable at: $\ asInteger put: #xSymbol. 987 newTable at: $% asInteger put: #xComment. 988 newTable at: $( asInteger put: #leftParenthesis. 989 newTable at: $) asInteger put: #rightParenthesis. 990 newTable at: $[ asInteger put: #leftParenthesis. 991 newTable at: $] asInteger put: #rightParenthesis. 992 newTable at: $. asInteger put: #period. 993 newTable at: $` asInteger put: #quote. 994 newTable at: $! asInteger put: #eof. 995 ScanningTable := newTable! ! 996 997!LispScanner class methodsFor: 'instance creation'! 998 999new 1000 ^(super new) initScanner; yourself! ! 1001 1002!LispScanner methodsFor: 'initialize-release'! 1003 1004initScanner 1005 failBlock := 1006 [:errorMessage || label string | 1007 label := errorMessage , ' near ' , (token printString contractTo: 10). 1008 string := source upToEnd. 1009 string isEmpty 1010 ifTrue: [string := '--> end of file'] 1011 ifFalse: [string := '--> ' , (string contractTo: 30)]. 1012 self error: 'scan error ', label, Character nl asString, string]. 1013 ! 1014 1015on: inputStream 1016 source := inputStream. 1017 mark := source position! ! 1018 1019!LispScanner methodsFor: 'private'! 1020 1021nextChar 1022 | char | 1023 source atEnd ifTrue: [ ^$! ]. 1024 char := source next. 1025 char = Character cr 1026 ifTrue: 1027 [char := Character nl. source peekFor: char]. 1028 ^char! 1029 1030peekChar 1031 | char | 1032 char := source peek. 1033 char = Character cr ifTrue: [char := Character nl]. 1034 char isNil ifTrue: [char := $! ]. 1035 ^char! 1036 1037unNextChar 1038 source skip: -1! ! 1039 1040!LispScanner methodsFor: 'reading'! 1041 1042numberFrom: aStream 1043 ^Number readFrom: aStream! 1044 1045objectFrom: aStream 1046 "POSSIBLE PORTABILITY PROBLEM HERE!" 1047 | buffer char | 1048 buffer := WriteStream on: (String new: 20). 1049 char := aStream next. 1050 1051 [char := aStream next. 1052 char = $}] 1053 whileFalse: 1054 [char == nil ifTrue: [^failBlock value: 'Syntax error unmatched ${']. 1055 buffer nextPut: char]. 1056 ^Behavior 1057 evaluate: buffer contents 1058 to: nil 1059 ifError: []! 1060 1061stringFrom: aStream 1062 | buffer char string | 1063 buffer := WriteStream on: (String new: 20). 1064 char := aStream next. 1065 char = $" ifTrue: [ 1066 [char := aStream peek. 1067 char ~~ nil] 1068 whileTrue: 1069 [char = $" 1070 ifTrue: 1071 [aStream next. 1072 char := aStream peek. 1073 char = $" ifFalse: [^String fromString: buffer contents]]. 1074 buffer nextPut: aStream next]]. 1075 string := aStream upToEnd. 1076 string size > 100 ifTrue: [string := string copyFrom: 1 to: 100]. 1077 ^failBlock value: 'Syntax error unmatched $'''! 1078 1079symbolFrom: aStream 1080 | buffer char type | 1081 buffer := WriteStream on: (String new: 20). 1082 char := aStream peek. 1083 [char notNil and: [(type := self tableAt: char) == #xSymbol or: [type == #xDigit or: [type == #xSign]]]] 1084 whileTrue: 1085 [buffer nextPut: aStream next. 1086 char := aStream peek]. 1087 buffer contents = 'nil' ifTrue: [^LispNil null]. 1088 ^Symbol intern: buffer contents! ! 1089 1090!LispScanner methodsFor: 'scanning'! 1091 1092multiChar: type 1093 self perform: type! 1094 1095nextToken 1096 | char | 1097 mark := source position. 1098 char := self peekChar. 1099 tokenType := self tableAt: char. 1100 [tokenType == #xDelimiter] 1101 whileTrue: 1102 [self nextChar. 1103 char := self peekChar. 1104 tokenType := self tableAt: char]. 1105 (tokenType at: 1) = $x 1106 ifTrue: [self multiChar: tokenType] 1107 ifFalse: [self singleChar: tokenType]. 1108 ^token! 1109 1110singleChar: type 1111 self nextChar. 1112 token := type! 1113 1114tableAt: char 1115 | index | 1116 index := char asInteger. 1117 ^index = 0 1118 ifFalse: [ScanningTable at: index] 1119 ifTrue: [#xBinary]! 1120 1121unNextToken 1122 source position: mark! ! 1123 1124!LispScanner methodsFor: 'x'! 1125 1126xBinary 1127 ^failBlock value: 'Syntax error ' , source peek printString! 1128 1129xBrace 1130 tokenType := #object. 1131 token := self objectFrom: source! 1132 1133xComment 1134 | char | 1135 [(char := self nextChar) = Character nl] 1136 whileFalse: [char == nil ifTrue: [^self nextToken]]. 1137 ^self nextToken! 1138 1139xDigit 1140 tokenType := #number. 1141 token := self numberFrom: source! 1142 1143xDoubleQuote 1144 tokenType := #string. 1145 token := self stringFrom: source! 1146 1147xSign 1148 | char sign | 1149 sign := self nextChar. 1150 char := self peekChar. 1151 char isDigit 1152 ifTrue: 1153 [tokenType := #number. 1154 token := self numberFrom: source. 1155 sign == $- ifTrue: [token := token negated]] 1156 ifFalse: 1157 [self unNextChar. 1158 tokenType := #symbol. 1159 token := self symbolFrom: source]! 1160 1161xSymbol 1162 tokenType := #symbol. 1163 token := self symbolFrom: source! ! 1164 1165 1166LispScanner initialize! 1167 1168!LispParser class methodsFor: 'copyright'! 1169 1170copyright 1171 ^'Copyright (C) 1995-1998 AOKI Atsushi, All Rights Reserved.'! 1172 1173system 1174 ^'Goodies'! 1175 1176version 1177 ^'003'! ! 1178 1179!LispParser class methodsFor: 'examples'! 1180 1181example1 1182 "LispParser example1." 1183 1184 | list | 1185 list := LispParser parse: '(1 2 3 4 (5 6 7 8 9) 10)'. 1186 ^list! 1187 1188example2 1189 "LispParser example2." 1190 1191 | list | 1192 list := LispParser parse: ' 1193 (10 (1 2) 1194 20 (3 4 . 100) 1195 30 (5 6) . 200) 1196 '. 1197 ^list! 1198 1199example3 1200 "LispParser example3." 1201 1202 | list | 1203 list := LispParser parse: ' 1204 (PetriNet Aoki 1205 (Place 1206 (p1 . {100@100}) 1207 (p2 . {200@200}) 1208 (p3 . {300@300}) 1209 (p4 . {400@400}) 1210 (p5 . {500@500})) 1211 (Transition 1212 (t1 . {100@100}) 1213 (t2 . {200@200}) 1214 (t3 . {300@300}) 1215 (t4 . {400@400}) 1216 (t5 . {500@500})) 1217 (InputFunction 1218 (t1 p1 p2 p3 p4 p5) 1219 (t2 . p4) 1220 (t3 . p5)) 1221 (OutputFunction 1222 (t1 p1 p2 p3 p4 p5) 1223 (t2 . p4) 1224 (t3 . p5)) 1225 (Marking {#(1 2 3 4 5)}))'. 1226 Transcript nl; show: list saveString. 1227 list := LispParser parse: list saveString. 1228 ^list! 1229 1230example4 1231 "LispParser example4." 1232 1233 | list | 1234 list := LispParser parse: '(1 2 3 4 (5 6 7 ~ 8 9) 10)'. 1235 ^list! 1236 1237example5 1238 "LispParser example5." 1239 1240 | list | 1241 list := LispParser parse: '(1 2 3 4 (5 6 7 {100@100 8 9) 10)'. "error" 1242 ^list! 1243 1244example6 1245 "LispParser example6." 1246 1247 | list | 1248 list := LispParser parse: '(1 2 3 4 (5 6 7 ''aaaaa 8 9) 10)'. 1249 ^list! 1250 1251example7 1252 "LispParser example7." 1253 1254 | list | 1255 list := LispParser parse: ' `(`(1 2 `3) . `4) '. "`(`(1 2 `3) . `4) -> (quote ((quote (1 2 (quote 3))) quote 4))" 1256 ^list! ! 1257 1258!LispParser class methodsFor: 'private'! 1259 1260makeStream: aStream 1261 1262 ^(aStream respondsTo: #next) "HACK" 1263 ifTrue: [aStream] 1264 ifFalse: [ReadStream on: aStream asString].! ! 1265 1266!LispParser class methodsFor: 'utilities'! 1267 1268parse: aStream 1269 ^self new parse: (self makeStream: aStream)! 1270 1271parse: aStream ifFail: aBlock 1272 ^self new parse: (self makeStream: aStream) 1273 ifFail: aBlock! ! 1274 1275!LispParser methodsFor: 'parsing'! 1276 1277parse: sourceStream 1278 | label string | 1279 ^self parse: sourceStream 1280 ifFail: 1281 [:errorMessage | 1282 label := errorMessage , ' near ' , (token printString contractTo: 20). 1283 string := source upToEnd. 1284 string isEmpty 1285 ifTrue: [string := '--> end of file'] 1286 ifFalse: [string := '--> ' , (string contractTo: 30)]. 1287 self error: 'parse error ', label, Character nl asString, string. 1288 ^LispNil null]! 1289 1290parse: sourceStream ifFail: aBlock 1291 | result | 1292 self init: sourceStream ifFail: aBlock. 1293 result := self scan. 1294 ^result! ! 1295 1296!LispParser methodsFor: 'private'! 1297 1298init: sourceStream ifFail: aBlock 1299 super on: sourceStream. 1300 failBlock := aBlock! ! 1301 1302!LispParser methodsFor: 'scan and parse'! 1303 1304scan 1305 source atEnd ifTrue: [^LispCons null]. 1306 ^self scanList! 1307 1308scanList 1309 | expression | 1310 self nextToken. 1311 tokenType == #eof ifTrue: [^LispCons null]. 1312 tokenType == #number ifTrue: [^token]. 1313 tokenType == #string ifTrue: [^token]. 1314 tokenType == #object ifTrue: [^token]. 1315 tokenType == #symbol ifTrue: [^token]. 1316 tokenType == #quote 1317 ifTrue: 1318 [expression := LispCons head: self scanList tail: LispCons null. 1319 ^LispCons head: #quote tail: expression]. 1320 tokenType == #leftParenthesis ifTrue: [^self scanListAux]. 1321 ^failBlock value: 'Syntax error'! 1322 1323scanListAux 1324 | cdr | 1325 self nextToken. 1326 tokenType == #eof ifTrue: [^LispCons null]. 1327 tokenType == #rightParenthesis ifTrue: [^LispCons null]. 1328 tokenType == #leftParenthesis ifTrue: [^LispCons head: self scanListAux tail: self scanListAux]. 1329 tokenType == #number ifTrue: [^LispCons head: token tail: self scanListAux]. 1330 tokenType == #string ifTrue: [^LispCons head: token tail: self scanListAux]. 1331 tokenType == #object ifTrue: [^LispCons head: token tail: self scanListAux]. 1332 tokenType == #symbol ifTrue: [^LispCons head: token tail: self scanListAux]. 1333 tokenType == #period 1334 ifTrue: 1335 [cdr := self scanList. 1336 self nextToken. 1337 tokenType == #rightParenthesis 1338 ifTrue: [^cdr] 1339 ifFalse: [^failBlock value: 'Syntax error']]. 1340 tokenType == #quote 1341 ifTrue: 1342 [cdr := LispCons head: self scanList tail: LispCons null. 1343 cdr := LispCons head: #quote tail: cdr. 1344 ^LispCons head: cdr tail: self scanListAux]. 1345 self unNextToken. 1346 ^failBlock value: 'Syntax error'! ! 1347 1348!LispParser methodsFor: 'scanning'! 1349 1350nextToken 1351 prevMark := mark. 1352 prevToken := token. 1353 prevTokenType := tokenType. 1354 ^super nextToken! 1355 1356unNextToken 1357 super unNextToken. 1358 mark := prevMark. 1359 token := prevToken. 1360 tokenType := prevTokenType! ! 1361 1362 1363 1364!LispTable class methodsFor: 'copyright'! 1365 1366copyright 1367 ^'Copyright (C) 1995-1998 AOKI Atsushi, All Rights Reserved.'! 1368 1369system 1370 ^'Goodies'! 1371 1372version 1373 ^'003'! ! 1374 1375!LispTable class methodsFor: 'instance creation'! 1376 1377new 1378 ^super new initialize! ! 1379 1380!LispTable methodsFor: 'accessing'! 1381 1382at: symbol 1383 ^self getprop: symbol key: #apval! 1384 1385at: symbol put: value 1386 self intern: symbol. 1387 ^self 1388 putprop: symbol 1389 key: #apval 1390 value: value! 1391 1392identifiers 1393 ^properties keys asSortedCollection! ! 1394 1395!LispTable methodsFor: 'adding'! 1396 1397add: symbol 1398 self intern: symbol! ! 1399 1400!LispTable methodsFor: 'initialize-release'! 1401 1402initialize 1403 properties := Dictionary new! ! 1404 1405!LispTable methodsFor: 'private'! 1406 1407errorSymbolNotFound 1408 self error: 'symbol not found'! 1409 1410intern: symbol 1411 (properties includesKey: symbol) 1412 ifFalse: [properties at: symbol put: Dictionary new]. 1413 ^symbol! ! 1414 1415!LispTable methodsFor: 'property access'! 1416 1417getprop: identifier key: key 1418 | property | 1419 property := properties at: identifier ifAbsent: [^self errorSymbolNotFound]. 1420 ^property at: key ifAbsent: [^nil]! 1421 1422putprop: identifier key: key value: value 1423 | property | 1424 property := properties at: identifier ifAbsent: [^self errorSymbolNotFound]. 1425 ^property at: key put: value! 1426 1427remprop: identifier key: key 1428 | property | 1429 property := properties at: identifier ifAbsent: [^self errorSymbolNotFound]. 1430 ^property removeKey: key ifAbsent: [^nil]! ! 1431 1432!LispTable methodsFor: 'removing'! 1433 1434remove: symbol 1435 ^properties removeKey: symbol ifAbsent: [^nil]! ! 1436 1437 1438 1439!LispInterpreter class methodsFor: 'copyright'! 1440 1441copyright 1442 ^'Copyright (C) 1995-1998 AOKI Atsushi, All Rights Reserved.'! 1443 1444system 1445 ^'Goodies'! 1446 1447version 1448 ^'003'! ! 1449 1450!LispInterpreter class methodsFor: 'examples'! 1451 1452example01 1453 "LispInterpreter example01." 1454 1455 | aList | 1456 aList := LispInterpreter evaluateFrom: ' 1457 1458 nil 1459 1460 '. 1461 ^aList! 1462 1463example02 1464 "LispInterpreter example02." 1465 1466 | aList | 1467 aList := LispInterpreter evaluateFrom: ' 1468 1469 123 1470 1471 '. 1472 ^aList! 1473 1474example03 1475 "LispInterpreter example03." 1476 1477 | aList | 1478 aList := LispInterpreter evaluateFrom: ' 1479 1480 "abc" 1481 1482 '. 1483 ^aList! 1484 1485example04 1486 "LispInterpreter example04." 1487 1488 | aList | 1489 aList := LispInterpreter evaluateFrom: ' 1490 1491 (cons 3 4) 1492 1493 '. 1494 ^aList! 1495 1496example05 1497 "LispInterpreter example05." 1498 1499 | aList | 1500 aList := LispInterpreter evaluateFrom: ' 1501 1502 (quote (3 4)) 1503 1504 '. 1505 ^aList! 1506 1507example06 1508 "LispInterpreter example06." 1509 1510 | aList | 1511 aList := LispInterpreter evaluateFrom: ' 1512 1513 (car (quote (3 4))) 1514 1515 '. 1516 ^aList! 1517 1518example07 1519 "LispInterpreter example07." 1520 1521 | aList | 1522 aList := LispInterpreter evaluateFrom: ' 1523 1524 (cdr (quote (3 4))) 1525 1526 '. 1527 ^aList! 1528 1529example08 1530 "LispInterpreter example08." 1531 1532 | aList | 1533 aList := LispInterpreter evaluateFrom: ' 1534 1535 (cons (car `(1 2 3)) `(3 4)) 1536 1537 '. 1538 ^aList! 1539 1540example09 1541 "LispInterpreter example09." 1542 1543 | aList | 1544 aList := LispInterpreter evaluateFrom: ' 1545 1546 (+ 1 2 3 4 5 6 7 8 9 10) 1547 1548 '. 1549 ^aList! 1550 1551example10 1552 "LispInterpreter example10." 1553 1554 | aList | 1555 aList := LispInterpreter evaluateFrom: ' 1556 1557 (progn 1558 (setq x 100) 1559 (setq y 200 z 300) 1560 (+ x y z)) 1561 1562 '. 1563 ^aList! 1564 1565example11 1566 "LispInterpreter example11." 1567 1568 | aList | 1569 aList := LispInterpreter evaluateFrom: ' 1570 1571 (progn 1572 (defun plus (x y) (+ x y)) 1573 (plus 3 4)) 1574 1575 '. 1576 ^aList! 1577 1578example12 1579 "LispInterpreter example12." 1580 1581 | aList | 1582 aList := LispInterpreter evaluateFrom: ' 1583 1584 (progn 1585 (defun concat (x y) 1586 (cond 1587 ((atom x) y) 1588 (t (cons 1589 (car x) 1590 (concat (cdr x) y))))) 1591 (concat `(1 2 3) `(4 5))) 1592 1593 '. 1594 ^aList! 1595 1596example13 1597 "LispInterpreter example13." 1598 1599 | aList | 1600 aList := LispInterpreter evaluateFrom: ' 1601 1602 (progn 1603 (defun plus nlambda (x) (plus1 x)) 1604 (defun plus1 lambda (x) 1605 (cond 1606 ((null x) 0) 1607 (t (+ (car x) (plus1 (cdr x)))))) 1608 (plus 1 2 3 4 5 6 7 8 9 10)) 1609 1610 '. 1611 ^aList! 1612 1613example14 1614 "LispInterpreter example14." 1615 1616 | aList | 1617 aList := LispInterpreter evaluateFrom: ' 1618 1619 ((lambda (x y) (cons x (cons y nil))) 3 4) 1620 1621 '. 1622 ^aList! 1623 1624example15 1625 "LispInterpreter example15." 1626 1627 | aList | 1628 aList := LispInterpreter evaluateFrom: ' 1629 1630 ((nlambda (x) x) 1 2 3 4 5 6 7 8 9 10) 1631 1632 '. 1633 ^aList! 1634 1635example16 1636 "LispInterpreter example16." 1637 1638 | aList | 1639 aList := LispInterpreter evaluateFrom: ' 1640 1641 (progn 1642 (setq x 100) 1643 (setq y 200) 1644 (do 1645 (x y) 1646 (setq x 10000) 1647 (setq y 20000) 1648 (send {Transcript} `nl) 1649 (send {Transcript} `show: (send x `printString)) 1650 (send {Transcript} `nl) 1651 (send {Transcript} `show: (send y `printString))) 1652 (send {Transcript} `nl) 1653 (send {Transcript} `show: (send x `printString)) 1654 (send {Transcript} `nl) 1655 (send {Transcript} `show: (send y `printString))) 1656 1657 '. 1658 ^aList! 1659 1660example17 1661 "LispInterpreter example17." 1662 1663 | aList | 1664 aList := LispInterpreter evaluateFrom: ' 1665 1666 (do 1667 (count) 1668 (setq count 1) 1669 (while 1670 (<= count 100) 1671 do 1672 (send {Transcript} `nl) 1673 (send {Transcript} `show: (send count `printString)) 1674 (setq count (+ count 1)))) 1675 1676 '. 1677 ^aList! 1678 1679example18 1680 "LispInterpreter example18." 1681 1682 | aList | 1683 aList := LispInterpreter evaluateFrom: ' 1684 1685 (do 1686 (count) 1687 (setq count 1) 1688 (repeat 1689 (send {Transcript} `nl) 1690 (send {Transcript} `show: (send count `printString)) 1691 (setq count (+ count 1)) 1692 until 1693 (<= count 100))) 1694 1695 '. 1696 ^aList! ! 1697 1698!LispInterpreter class methodsFor: 'instance creation'! 1699 1700new 1701 ^super new initialize! ! 1702 1703!LispInterpreter class methodsFor: 'printing'! 1704 1705printString: anObject 1706 "LispInterpreter printString: 'string'." 1707 "LispInterpreter printString: #symbol." 1708 "LispInterpreter printString: 123." 1709 "LispInterpreter printString: 123.456." 1710 "LispInterpreter printString: 123.456e7." 1711 "LispInterpreter printString: LispNil null." 1712 "LispInterpreter printString: nil." 1713 1714 | aStream | 1715 aStream := WriteStream on: (String new: 32). 1716 (anObject isKindOf: LispCons) 1717 ifTrue: [anObject printOn: aStream level: 0] 1718 ifFalse: [LispCons new printOn: aStream object: anObject]. 1719 ^aStream contents! ! 1720 1721!LispInterpreter class methodsFor: 'public access'! 1722 1723evaluate: sExpression 1724 ^self new evaluateTopLevel: sExpression ifFail: [:errorMessage | self error: errorMessage]! 1725 1726evaluate: sExpression ifFail: aBlock 1727 ^self new evaluateTopLevel: sExpression ifFail: aBlock! 1728 1729evaluateFrom: aStream 1730 ^self new evaluateTopLevel: (LispParser parse: aStream) 1731 ifFail: [:errorMessage | self error: errorMessage]! 1732 1733evaluateFrom: aStream ifFail: aBlock 1734 ^self new evaluateTopLevel: (LispCons parse: aStream ifFail: aBlock) 1735 ifFail: aBlock! ! 1736 1737!LispInterpreter methodsFor: 'accessing'! 1738 1739textCollector 1740 ^textCollector! 1741 1742textCollector: anObject 1743 textCollector := anObject! ! 1744 1745!LispInterpreter methodsFor: 'error handling'! 1746 1747fatal: message 1748 bindStack reverseDo: [:assoc | assoc key notNil ifTrue: [assoc value notNil 1749 ifTrue: [self 1750 putprop: assoc key 1751 key: #apval 1752 value: assoc value] 1753 ifFalse: [self remprop: assoc key key: #apval]]]. 1754 ^failBlock value: '*** Error: ' , message! ! 1755 1756!LispInterpreter methodsFor: 'evaluating'! 1757 1758evaluate: sExpression 1759 | apval | 1760 (sExpression isKindOf: LispList) 1761 ifTrue: [^self listEvaluate: sExpression]. 1762 (sExpression isKindOf: Symbol) 1763 ifTrue: 1764 [sExpression = #t ifTrue: [^#t]. 1765 lispTable intern: sExpression. 1766 apval := lispTable getprop: sExpression key: #apval. 1767 apval isNil ifTrue: [^self fatal: (self printString: sExpression) 1768 , ' is unbound atom']. 1769 ^apval]. 1770 ^sExpression! 1771 1772evaluateTopLevel: sExpression 1773 ^self evaluateTopLevel: sExpression ifFail: 1774 [:errorMessage | 1775 Transcript show: errorMessage; nl. 1776 LispNil null]! 1777 1778evaluateTopLevel: sExpression ifFail: aBlock 1779 failBlock := aBlock. 1780 ^self evaluate: sExpression! 1781 1782listEvaluate: sExpression 1783 | funcName arguList funcBody | 1784 sExpression null ifTrue: [^sExpression]. 1785 funcName := sExpression head. 1786 arguList := sExpression tail. 1787 (funcName isKindOf: LispCons) 1788 ifTrue: 1789 [funcBody := funcName. 1790 funcBody head = #lambda 1791 ifTrue: 1792 [funcBody := LispCons head: #lambda tail: funcBody. 1793 ^self exprEval: funcBody arguList: arguList]. 1794 funcBody head = #nlambda 1795 ifTrue: 1796 [funcBody := LispCons head: #nlambda tail: funcBody. 1797 ^self fexprEval: funcBody arguList: arguList]. 1798 ^self fatal: 'unexpected function ' , (self printString: funcBody)]. 1799 (funcName isKindOf: Symbol) 1800 ifFalse: [^self fatal: 'null function ' , (self printString: funcName)]. 1801 funcBody := self getprop: funcName key: #fexpr. 1802 funcBody = LispNil null ifFalse: [^self fexprEval: funcBody arguList: arguList]. 1803 funcBody := self getprop: funcName key: #expr. 1804 funcBody = LispNil null ifFalse: [^self exprEval: funcBody arguList: arguList]. 1805 funcBody := self getprop: funcName key: #fsubr. 1806 funcBody = LispNil null ifFalse: [^self fsubrEval: funcBody arguList: arguList]. 1807 funcBody := self getprop: funcName key: #subr. 1808 funcBody = LispNil null ifFalse: [^self subrEval: funcBody arguList: arguList]. 1809 ^self fatal: 'undefined function ' , (self printString: funcName)! ! 1810 1811!LispInterpreter methodsFor: 'fsubr functions'! 1812 1813fsubrAdd: arguList 1814 | v a | 1815 v := LispNil null. 1816 arguList 1817 do: 1818 [:each | 1819 a := self evaluate: each. 1820 (a isKindOf: Number) 1821 ifFalse: [^self fatal: 'unexpected argument ' , (self printString: a) , ' for +']. 1822 v = LispNil null 1823 ifTrue: [v := a] 1824 ifFalse: [v := v + a]]. 1825 ^v! 1826 1827fsubrCond: arguList 1828 | result | 1829 arguList do: [:each | (self evaluate: each head) 1830 ~= LispNil null 1831 ifTrue: 1832 [result := LispNil null. 1833 (each tail isKindOf: LispCons) 1834 ifTrue: [each tail do: [:expr | result := self evaluate: expr]]. 1835 ^result]]. 1836 ^LispNil null! 1837 1838fsubrDefun: arguList 1839 | funcName funcType | 1840 funcName := arguList head. 1841 (funcName isKindOf: Symbol) 1842 ifFalse: [^self fatal: 'unexpected function name ' , (self printString: funcName) , ' for defun']. 1843 funcType := arguList tail head. 1844 funcType = #lambda 1845 ifTrue: 1846 [self 1847 putprop: funcName 1848 key: #expr 1849 value: arguList. 1850 ^funcName]. 1851 funcType = #nlambda 1852 ifTrue: 1853 [self 1854 putprop: funcName 1855 key: #fexpr 1856 value: arguList. 1857 ^funcName]. 1858 self 1859 putprop: funcName 1860 key: #expr 1861 value: (LispCons head: funcName tail: (LispCons head: #lambda tail: arguList tail)). 1862 ^funcName! 1863 1864fsubrDiv: arguList 1865 | v a | 1866 v := LispNil null. 1867 arguList 1868 do: 1869 [:each | 1870 a := self evaluate: each. 1871 (a isKindOf: Number) 1872 ifFalse: [^self fatal: 'unexpected argument ' , (self printString: a) , ' for /']. 1873 v = LispNil null 1874 ifTrue: [v := a] 1875 ifFalse: [v := v / a]]. 1876 ^v! 1877 1878fsubrDo: arguList 1879 | locals executions result | 1880 locals := arguList head. 1881 executions := arguList tail. 1882 self bindMark. 1883 locals do: [:lvar | self bind: lvar value: LispNil null]. 1884 result := LispNil null. 1885 executions do: [:each | result := self evaluate: each]. 1886 self unbind. 1887 ^result! 1888 1889fsubrIdiv: arguList 1890 | v a | 1891 v := LispNil null. 1892 arguList 1893 do: 1894 [:each | 1895 a := self evaluate: each. 1896 (a isKindOf: Number) 1897 ifFalse: [^self fatal: 'unexpected argument ' , (self printString: a) , ' for //']. 1898 v = LispNil null 1899 ifTrue: [v := a] 1900 ifFalse: [v := v // a]]. 1901 ^v! 1902 1903fsubrIf: arguList 1904 | predicate then list truePart falsePart bool result | 1905 predicate := arguList head. 1906 then := arguList tail head. 1907 list := arguList tail tail. 1908 truePart := LispNil null. 1909 falsePart := LispNil null. 1910 bool := true. 1911 list do: [:each | each = #else 1912 ifTrue: [bool := false] 1913 ifFalse: [bool 1914 ifTrue: [truePart := LispCons head: each tail: truePart] 1915 ifFalse: [falsePart := LispCons head: each tail: falsePart]]]. 1916 then = #then ifFalse: [^self fatal: 'unexpected format for if']. 1917 truePart := truePart reverse. 1918 falsePart := falsePart reverse. 1919 result := LispNil null. 1920 (self evaluate: predicate) 1921 = LispNil null 1922 ifTrue: [falsePart do: [:each | result := self evaluate: each]] 1923 ifFalse: [truePart do: [:each | result := self evaluate: each]]. 1924 ^result! 1925 1926fsubrMlt: arguList 1927 | v a | 1928 v := LispNil null. 1929 arguList 1930 do: 1931 [:each | 1932 a := self evaluate: each. 1933 (a isKindOf: Number) 1934 ifFalse: [^self fatal: 'unexpected argument ' , (self printString: a) , ' for *']. 1935 v = LispNil null 1936 ifTrue: [v := a] 1937 ifFalse: [v := v * a]]. 1938 ^v! 1939 1940fsubrMod: arguList 1941 | v a | 1942 v := LispNil null. 1943 arguList 1944 do: 1945 [:each | 1946 a := self evaluate: each. 1947 (a isKindOf: Number) 1948 ifFalse: [^self fatal: 'unexpected argument ' , (self printString: a) , ' for \\']. 1949 v = LispNil null 1950 ifTrue: [v := a] 1951 ifFalse: [v := v \\ a]]. 1952 ^v! 1953 1954fsubrProgn: arguList 1955 | result | 1956 result := LispNil null. 1957 arguList do: [:each | result := self evaluate: each]. 1958 ^result! 1959 1960fsubrQuote: arguList 1961 ^arguList head! 1962 1963fsubrRepeat: arguList 1964 | reverse predicate until executions result | 1965 reverse := arguList reverse. 1966 predicate := reverse head. 1967 until := reverse tail head. 1968 executions := reverse tail tail reverse. 1969 until = #until ifFalse: [^self fatal: 'unexpected format for repeat']. 1970 result := LispNil null. 1971 executions do: [:each | result := self evaluate: each]. 1972 [(self evaluate: predicate) 1973 = LispNil null] 1974 whileFalse: [executions do: [:each | result := self evaluate: each]]. 1975 ^result! 1976 1977fsubrSend: arguList 1978 | list receiver selector arguments result | 1979 list := arguList. 1980 receiver := self evaluate: list head. 1981 list := list tail. 1982 selector := self evaluate: list head. 1983 (selector isKindOf: Symbol) 1984 ifFalse: [^self fatal: 'unexpected selector ' , (self printString: selector) , ' for send']. 1985 list := list tail. 1986 arguments := OrderedCollection new. 1987 [list isKindOf: LispCons] 1988 whileTrue: 1989 [arguments add: (self evaluate: list head). 1990 list := list tail]. 1991 result := receiver perform: selector withArguments: arguments asArray. 1992 ^result! 1993 1994fsubrSetq: arguList 1995 | list a1 a2 | 1996 list := arguList. 1997 a2 := LispNil null. 1998 [list isKindOf: LispCons] 1999 whileTrue: 2000 [a1 := list head. 2001 (a1 isKindOf: Symbol) 2002 ifFalse: [^self fatal: 'unexpected variable ' , (self printString: a1) , ' for setq']. 2003 list := list tail. 2004 a2 := self evaluate: list head. 2005 self 2006 putprop: a1 2007 key: #apval 2008 value: a2. 2009 list := list tail]. 2010 ^a2! 2011 2012fsubrSub: arguList 2013 | v a | 2014 v := LispNil null. 2015 arguList 2016 do: 2017 [:each | 2018 a := self evaluate: each. 2019 (a isKindOf: Number) 2020 ifFalse: [^self fatal: 'unexpected argument ' , (self printString: a) , ' for -']. 2021 v = LispNil null 2022 ifTrue: [v := a] 2023 ifFalse: [v := v - a]]. 2024 ^v! 2025 2026fsubrWhile: arguList 2027 | predicate do executions result | 2028 predicate := arguList head. 2029 do := arguList tail head. 2030 executions := arguList tail tail. 2031 do = #do ifFalse: [^self fatal: 'unexpected format for while']. 2032 result := LispNil null. 2033 [(self evaluate: predicate) 2034 = LispNil null] 2035 whileFalse: [executions do: [:each | result := self evaluate: each]]. 2036 ^result! ! 2037 2038!LispInterpreter methodsFor: 'func eval'! 2039 2040exprEval: funcBody arguList: arguList 2041 | expression funcName lvarList lvar result | 2042 expression := funcBody. 2043 funcName := expression head. 2044 expression := expression tail. 2045 expression := expression tail. 2046 lvarList := expression head. 2047 expression := expression tail. 2048 arguList length ~= lvarList length ifTrue: [^self fatal: 'too few or many arguments ' , (self printString: arguList) , ' vs ' , (self printString: lvarList) , ' for ' , funcName]. 2049 self bindMark. 2050 arguList 2051 do: 2052 [:each | 2053 lvar := lvarList head. 2054 self bind: lvar value: (self evaluate: each). 2055 lvarList := lvarList tail]. 2056 expression do: [:each | result := self evaluate: each]. 2057 self unbind. 2058 ^result! 2059 2060fexprEval: funcBody arguList: arguList 2061 | expression funcName lvarList lvar result | 2062 expression := funcBody. 2063 funcName := expression head. 2064 expression := expression tail. 2065 expression := expression tail. 2066 lvarList := expression head. 2067 expression := expression tail. 2068 lvarList length ~= 1 ifTrue: [^self fatal: 'too few or many arguments ' , (self printString: lvarList) , ' for ' , (self printString: funcName)]. 2069 self bindMark. 2070 lvar := lvarList head. 2071 self bind: lvar value: arguList. 2072 expression do: [:each | result := self evaluate: each]. 2073 self unbind. 2074 ^result! 2075 2076fsubrEval: funcBody arguList: arguList 2077 | messageSelector | 2078 messageSelector := funcBody tail head. 2079 ^self perform: messageSelector with: arguList! 2080 2081subrEval: funcBody arguList: arguList 2082 | funcName messageSelector arguCount arguBuffer list | 2083 funcName := funcBody head. 2084 messageSelector := funcBody tail head. 2085 arguCount := funcBody tail tail head. 2086 arguBuffer := OrderedCollection new. 2087 list := arguList. 2088 arguCount 2089 timesRepeat: 2090 [list null ifTrue: [^self fatal: 'too few arguments for ' , (self printString: funcName)]. 2091 arguBuffer add: (self evaluate: list head). 2092 list := list tail]. 2093 list null not ifTrue: [^self fatal: 'too many arguments for ' , (self printString: funcName)]. 2094 arguBuffer isEmpty 2095 ifTrue: [^self perform: messageSelector] 2096 ifFalse: [^self perform: messageSelector with: arguBuffer asArray]! ! 2097 2098!LispInterpreter methodsFor: 'initialize-release'! 2099 2100initialize 2101 lispTable := LispTable new. 2102 bindStack := OrderedCollection new. 2103 failBlock := [:errorMessage | self error: errorMessage]. 2104 textCollector := Transcript. 2105 self initializeSubrFunctions. 2106 self initializeFsubrFunctions. 2107 self initializeExprFunctions. 2108 self initializeFexprFunctions! 2109 2110initializeExprFunctions 2111 self evaluateTopLevel: (LispParser parse: ' 2112 2113 % Expr Functions 2114 (progn 2115 2116 % ++ 2117 (defun ++ lambda (x) 2118 (+ x 1)) 2119 2120 % -- 2121 (defun -- lambda (x) 2122 (- x 1)) 2123 2124 % assoc 2125 (defun assoc lambda (x a) 2126 (cond 2127 ((null a) nil) 2128 ((equal x (car (car a))) (car a)) 2129 (t (assoc x (cdr a))))) 2130 2131 % copy 2132 (defun copy lambda (x) 2133 (cond 2134 ((null x) nil) 2135 (t (cons (car x) (copy (cdr x)))))) 2136 2137 % mapc 2138 (defun mapc lambda (f x) 2139 (cond 2140 ((null x) nil) 2141 (t (progn 2142 (eval (cons f (cons `(car x) nil))) 2143 (mapc f (cdr x)))))) 2144 2145 % mapcar 2146 (defun mapcar lambda (f x) 2147 (cond 2148 ((null x) nil) 2149 (t (cons 2150 (eval (cons f (cons `(car x) nil))) 2151 (mapcar f (cdr x)))))) 2152 2153 ) % end 2154 2155 ')! 2156 2157initializeFexprFunctions 2158 self evaluateTopLevel: (LispParser parse: ' 2159 2160 % Expr Functions 2161 (progn 2162 2163 % and 2164 (defun and nlambda (x) 2165 (do (list) 2166 (setq list x) 2167 (while 2168 (if (null list) then nil else (eval (car list))) 2169 do 2170 (setq list (cdr list))) 2171 (if (null list) then t else nil))) 2172 2173 % list 2174 (defun list nlambda (x) 2175 (mapcar `eval x)) 2176 2177 % or 2178 (defun or nlambda (x) 2179 (do (list) 2180 (setq list x) 2181 (while 2182 (if (null list) then nil else (not (eval (car list)))) 2183 do 2184 (setq list (cdr list))) 2185 (if (null list) then nil else t))) 2186 2187 ) % end 2188 2189 ')! 2190 2191initializeFsubrFunctions 2192 self setFsubrFunc: #(#* #fsubrMlt:). 2193 self setFsubrFunc: #(#+ #fsubrAdd:). 2194 self setFsubrFunc: #(#- #fsubrSub:). 2195 self setFsubrFunc: #(#/ #fsubrDiv:). 2196 self setFsubrFunc: #(#// #fsubrIdiv:). 2197 self setFsubrFunc: #(#cond #fsubrCond:). 2198 self setFsubrFunc: #(#defun #fsubrDefun:). 2199 self setFsubrFunc: #(#do #fsubrDo:). 2200 self setFsubrFunc: #(#if #fsubrIf:). 2201 self setFsubrFunc: #(#progn #fsubrProgn:). 2202 self setFsubrFunc: #(#quote #fsubrQuote:). 2203 self setFsubrFunc: #(#repeat #fsubrRepeat:). 2204 self setFsubrFunc: #(#send #fsubrSend:). 2205 self setFsubrFunc: #(#setq #fsubrSetq:). 2206 self setFsubrFunc: #(#while #fsubrWhile:). 2207 self setFsubrFunc: #(#\\ #fsubrMod:).! 2208 2209initializeSubrFunctions 2210 self setSubrFunc: #(#< #subrLt: 2). 2211 self setSubrFunc: #(#<= #subrLe: 2). 2212 self setSubrFunc: #(#= #subrEqual: 2). 2213 self setSubrFunc: #(#== #subrEq: 2). 2214 self setSubrFunc: #(#> #subrGt: 2). 2215 self setSubrFunc: #(#>= #subrGe: 2). 2216 self setSubrFunc: #(#append #subrAppend: 2). 2217 self setSubrFunc: #(#atom #subrAtom: 1). 2218 self setSubrFunc: #(#car #subrCar: 1). 2219 self setSubrFunc: #(#cdr #subrCdr: 1). 2220 self setSubrFunc: #(#cons #subrCons: 2). 2221 self setSubrFunc: #(#consp #subrConsp: 1). 2222 self setSubrFunc: #(#dtpr #subrConsp: 1). 2223 self setSubrFunc: #(#doublep #subrDoublep: 1). 2224 self setSubrFunc: #(#eq #subrEq: 2). 2225 self setSubrFunc: #(#equal #subrEqual: 2). 2226 self setSubrFunc: #(#eval #subrEval: 1). 2227 self setSubrFunc: #(#exprs #subrExprs 0). 2228 self setSubrFunc: #(#fexprs #subrFexprs 0). 2229 self setSubrFunc: #(#floatp #subrFloatp: 1). 2230 self setSubrFunc: #(#fsubrs #subrFsubrs 0). 2231 self setSubrFunc: #(#gc #subrGc 0). 2232 self setSubrFunc: #(#gensym #subrGensym 0). 2233 self setSubrFunc: #(#getprop #subrGetprop: 2). 2234 self setSubrFunc: #(#integerp #subrIntegerp: 1). 2235 self setSubrFunc: #(#last #subrLast: 1). 2236 self setSubrFunc: #(#length #subrLength: 1). 2237 self setSubrFunc: #(#listp #subrListp: 1). 2238 self setSubrFunc: #(#member #subrMember: 2). 2239 self setSubrFunc: #(#memq #subrMemq: 2). 2240 self setSubrFunc: #(#nconc #subrNconc: 2). 2241 self setSubrFunc: #(#neq #subrNeq: 2). 2242 self setSubrFunc: #(#nequal #subrNequal: 2). 2243 self setSubrFunc: #(#not #subrNull: 1). 2244 self setSubrFunc: #(#nth #subrNth: 2). 2245 self setSubrFunc: #(#null #subrNull: 1). 2246 self setSubrFunc: #(#numberp #subrNumberp: 1). 2247 self setSubrFunc: #(#oblist #subrOblist 0). 2248 self setSubrFunc: #(#pp #subrPp: 1). 2249 self setSubrFunc: #(#princ #subrPrinc: 1). 2250 self setSubrFunc: #(#print #subrPrint: 1). 2251 self setSubrFunc: #(#putprop #subrPutprop: 3). 2252 self setSubrFunc: #(#remprop #subrRemprop: 2). 2253 self setSubrFunc: #(#reverse #subrReverse: 1). 2254 self setSubrFunc: #(#rplaca #subrRplaca: 2). 2255 self setSubrFunc: #(#rplacd #subrRplacd: 2). 2256 self setSubrFunc: #(#stringp #subrStringp: 1). 2257 self setSubrFunc: #(#subrs #subrSubrs 0). 2258 self setSubrFunc: #(#symbolp #subrSymbolp: 1). 2259 self setSubrFunc: #(#terpri #subrTerpri 0). 2260 self setSubrFunc: #(#~= #subrNequal: 2). 2261 self setSubrFunc: #(#~~ #subrNeq: 2)! ! 2262 2263!LispInterpreter methodsFor: 'printing'! 2264 2265printString: anObject 2266 ^self class printString: anObject! ! 2267 2268!LispInterpreter methodsFor: 'private'! 2269 2270setFsubrFunc: bodyArray 2271 self 2272 putprop: (bodyArray at: 1) asSymbol 2273 key: #fsubr 2274 value: (LispCons list: bodyArray)! 2275 2276setSubrFunc: bodyArray 2277 self 2278 putprop: (bodyArray at: 1) asSymbol 2279 key: #subr 2280 value: (LispCons list: bodyArray)! ! 2281 2282!LispInterpreter methodsFor: 'property access'! 2283 2284getprop: identifier key: key 2285 | value | 2286 lispTable intern: identifier. 2287 value := lispTable getprop: identifier key: key. 2288 value isNil ifTrue: [^LispNil null]. 2289 ^value! 2290 2291putprop: identifier key: key value: value 2292 lispTable intern: identifier. 2293 ^lispTable 2294 putprop: identifier 2295 key: key 2296 value: value! 2297 2298remprop: identifier key: key 2299 | value | 2300 lispTable intern: identifier. 2301 value := lispTable remprop: identifier key: key. 2302 value isNil ifTrue: [^LispNil null]. 2303 ^value! ! 2304 2305!LispInterpreter methodsFor: 'shallow binding'! 2306 2307bind: symbol value: value 2308 | saveValue assoc | 2309 lispTable intern: symbol. 2310 saveValue := lispTable getprop: symbol key: #apval. 2311 assoc := Association key: symbol value: saveValue. 2312 bindStack addLast: assoc. 2313 self 2314 putprop: symbol 2315 key: #apval 2316 value: value! 2317 2318bindMark 2319 | assoc | 2320 assoc := Association key: nil value: nil. 2321 bindStack addLast: assoc! 2322 2323unbind 2324 | assoc | 2325 2326 [assoc := bindStack removeLast. 2327 assoc key notNil] 2328 whileTrue: [assoc value notNil 2329 ifTrue: [self 2330 putprop: assoc key 2331 key: #apval 2332 value: assoc value] 2333 ifFalse: [self remprop: assoc key key: #apval]]! ! 2334 2335!LispInterpreter methodsFor: 'subr functions'! 2336 2337subrAppend: arguArray 2338 | a1 a2 | 2339 a1 := arguArray at: 1. 2340 a2 := arguArray at: 2. 2341 (a1 isKindOf: LispCons) 2342 ifFalse: [^self fatal: 'unexpected argument ' , (self printString: a1) , ' for append']. 2343 (a2 isKindOf: LispCons) 2344 ifFalse: [^self fatal: 'unexpected argument ' , (self printString: a2) , ' for append']. 2345 ^a1 append: a2! 2346 2347subrAtom: arguArray 2348 | a1 | 2349 a1 := arguArray at: 1. 2350 (a1 isKindOf: LispCons) ifFalse: [^#t]. 2351 ^LispNil null! 2352 2353subrCar: arguArray 2354 | list | 2355 list := arguArray at: 1. 2356 (list isKindOf: LispCons) 2357 ifTrue: [^list head]. 2358 (list isKindOf: LispNil) 2359 ifTrue: [^LispNil null]. 2360 ^self fatal: 'unexpected argument ' , (self printString: list) , ' for car'! 2361 2362subrCdr: arguArray 2363 | list | 2364 list := arguArray at: 1. 2365 (list isKindOf: LispCons) 2366 ifTrue: [^list tail]. 2367 (list isKindOf: LispNil) 2368 ifTrue: [^LispNil null]. 2369 ^self fatal: 'unexpected argument ' , (self printString: list) , ' for cdr'! 2370 2371subrCons: arguArray 2372 ^LispCons head: (arguArray at: 1) 2373 tail: (arguArray at: 2)! 2374 2375subrConsp: arguArray 2376 | a1 | 2377 a1 := arguArray at: 1. 2378 (a1 isKindOf: LispCons) 2379 ifTrue: [^#t]. 2380 ^LispNil null! 2381 2382subrDoublep: arguArray 2383 | a1 | 2384 ^self subrFloatp: arguArray 2385 "a1 := arguArray at: 1. 2386 (a1 isKindOf: Double) 2387 ifTrue: [^#t]. 2388 ^LispNil null"! 2389 2390subrEq: arguArray 2391 | bool | 2392 (arguArray at: 1) 2393 == (arguArray at: 2) 2394 ifTrue: [bool := #t] 2395 ifFalse: [bool := LispNil null]. 2396 ^bool! 2397 2398subrEqual: arguArray 2399 | bool | 2400 (arguArray at: 1) 2401 = (arguArray at: 2) 2402 ifTrue: [bool := #t] 2403 ifFalse: [bool := LispNil null]. 2404 ^bool! 2405 2406subrEval: arguArray 2407 ^self evaluate: (arguArray at: 1)! 2408 2409subrExprs 2410 | list | 2411 list := LispNil null. 2412 self subrOblist reverse do: [:id | (self getprop: id key: #expr) 2413 = LispNil null ifFalse: [list := LispCons head: id tail: list]]. 2414 ^list! 2415 2416subrFexprs 2417 | list | 2418 list := LispNil null. 2419 self subrOblist reverse do: [:id | (self getprop: id key: #fexpr) 2420 = LispNil null ifFalse: [list := LispCons head: id tail: list]]. 2421 ^list! 2422 2423subrFloatp: arguArray 2424 | a1 | 2425 a1 := arguArray at: 1. 2426 (a1 isKindOf: Float) 2427 ifTrue: [^#t]. 2428 ^LispNil null! 2429 2430subrFsubrs 2431 | list | 2432 list := LispNil null. 2433 self subrOblist reverse do: [:id | (self getprop: id key: #fsubr) 2434 = LispNil null ifFalse: [list := LispCons head: id tail: list]]. 2435 ^list! 2436 2437subrGc 2438 "ObjectMemory globalCompactingGC." 2439 Smalltalk compact. 2440 Transcript nl; show: 'garbage collecting'. 2441 ^#t! 2442 2443subrGe: arguArray 2444 | a1 a2 | 2445 a1 := arguArray at: 1. 2446 a2 := arguArray at: 2. 2447 (a1 isKindOf: LispList) 2448 ifTrue: [^self fatal: 'unexpected argument ' , (self printString: a1) , ' for >=']. 2449 (a2 isKindOf: LispList) 2450 ifTrue: [^self fatal: 'unexpected argument ' , (self printString: a2) , ' for >=']. 2451 a1 >= a2 ifTrue: [^#t]. 2452 ^LispNil null! 2453 2454subrGensym 2455 | clock | 2456 (Delay forMilliseconds: 1) wait. 2457 clock := Time millisecondClockValue. 2458 ^('id' , clock printString) asSymbol! 2459 2460subrGetprop: arguArray 2461 | a1 a2 | 2462 a1 := arguArray at: 1. 2463 a2 := arguArray at: 2. 2464 (a1 isKindOf: Symbol) 2465 ifFalse: [^self fatal: 'unexpected argument ' , (self printString: a1) , ' for getprop']. 2466 (a2 isKindOf: Symbol) 2467 ifFalse: [^self fatal: 'unexpected argument ' , (self printString: a2) , ' for getprop']. 2468 ^self getprop: a1 key: a2! 2469 2470subrGt: arguArray 2471 | a1 a2 | 2472 a1 := arguArray at: 1. 2473 a2 := arguArray at: 2. 2474 (a1 isKindOf: LispList) 2475 ifTrue: [^self fatal: 'unexpected argument ' , (self printString: a1) , ' for >']. 2476 (a2 isKindOf: LispList) 2477 ifTrue: [^self fatal: 'unexpected argument ' , (self printString: a2) , ' for >']. 2478 a1 > a2 ifTrue: [^#t]. 2479 ^LispNil null! 2480 2481subrIntegerp: arguArray 2482 | a1 | 2483 a1 := arguArray at: 1. 2484 (a1 isKindOf: Integer) 2485 ifTrue: [^#t]. 2486 ^LispNil null! 2487 2488subrLast: arguArray 2489 | list | 2490 list := arguArray at: 1. 2491 (list isKindOf: LispCons) 2492 ifTrue: [^list last]. 2493 ^self fatal: 'unexpected argument ' , (self printString: list) , ' for last'! 2494 2495subrLe: arguArray 2496 | a1 a2 | 2497 a1 := arguArray at: 1. 2498 a2 := arguArray at: 2. 2499 (a1 isKindOf: LispList) 2500 ifTrue: [^self fatal: 'unexpected argument ' , (self printString: a1) , ' for <=']. 2501 (a2 isKindOf: LispList) 2502 ifTrue: [^self fatal: 'unexpected argument ' , (self printString: a2) , ' for <=']. 2503 a1 <= a2 ifTrue: [^#t]. 2504 ^LispNil null! 2505 2506subrLength: arguArray 2507 | list | 2508 list := arguArray at: 1. 2509 (list isKindOf: LispCons) 2510 ifTrue: [^list length]. 2511 ^self fatal: 'unexpected argument ' , (self printString: list) , ' for length'! 2512 2513subrListp: arguArray 2514 | a1 | 2515 a1 := arguArray at: 1. 2516 (a1 isKindOf: LispList) 2517 ifTrue: [^#t]. 2518 ^LispNil null! 2519 2520subrLt: arguArray 2521 | a1 a2 | 2522 a1 := arguArray at: 1. 2523 a2 := arguArray at: 2. 2524 (a1 isKindOf: LispList) 2525 ifTrue: [^self fatal: 'unexpected argument ' , (self printString: a1) , ' for <']. 2526 (a2 isKindOf: LispList) 2527 ifTrue: [^self fatal: 'unexpected argument ' , (self printString: a2) , ' for <']. 2528 a1 < a2 ifTrue: [^#t]. 2529 ^LispNil null! 2530 2531subrMember: arguArray 2532 | a1 a2 | 2533 a1 := arguArray at: 1. 2534 a2 := arguArray at: 2. 2535 (a2 isKindOf: LispCons) 2536 ifFalse: [^self fatal: 'unexpected argument ' , (self printString: a2) , ' for member']. 2537 ^a2 member: a1! 2538 2539subrMemq: arguArray 2540 | a1 a2 | 2541 a1 := arguArray at: 1. 2542 a2 := arguArray at: 2. 2543 (a2 isKindOf: LispCons) 2544 ifFalse: [^self fatal: 'unexpected argument ' , (self printString: a2) , ' for memq']. 2545 ^a2 memq: a1! 2546 2547subrNconc: arguArray 2548 | a1 a2 | 2549 a1 := arguArray at: 1. 2550 a2 := arguArray at: 2. 2551 (a1 isKindOf: LispCons) 2552 ifFalse: [^self fatal: 'unexpected argument ' , (self printString: a1) , ' for nconc']. 2553 a1 nconc: a2. 2554 ^a1! 2555 2556subrNeq: arguArray 2557 | bool | 2558 ((arguArray at: 1) 2559 == (arguArray at: 2)) not 2560 ifTrue: [bool := #t] 2561 ifFalse: [bool := LispNil null]. 2562 ^bool! 2563 2564subrNequal: arguArray 2565 | bool | 2566 ((arguArray at: 1) 2567 = (arguArray at: 2)) not 2568 ifTrue: [bool := #t] 2569 ifFalse: [bool := LispNil null]. 2570 ^bool! 2571 2572subrNth: arguArray 2573 | a1 a2 | 2574 a1 := arguArray at: 1. 2575 a2 := arguArray at: 2. 2576 (a1 isKindOf: Number) 2577 ifFalse: [^self fatal: 'unexpected argument ' , (self printString: a1) , ' for nth']. 2578 (a2 isKindOf: LispCons) 2579 ifFalse: [^self fatal: 'unexpected argument ' , (self printString: a2) , ' for nth']. 2580 ^a2 nth: a1! 2581 2582subrNull: arguArray 2583 ((arguArray at: 1) 2584 isMemberOf: LispNil) 2585 ifTrue: [^#t]. 2586 ^LispNil null! 2587 2588subrNumberp: arguArray 2589 | a1 | 2590 a1 := arguArray at: 1. 2591 (a1 isKindOf: Number) 2592 ifTrue: [^#t]. 2593 ^LispNil null! 2594 2595subrOblist 2596 | list | 2597 list := LispNil null. 2598 lispTable identifiers reverseDo: [:each | list := LispCons head: each tail: list]. 2599 ^list! 2600 2601subrPp: arguArray 2602 | a pretty | 2603 a := arguArray at: 1. 2604 pretty := a ppString. 2605 textCollector show: pretty. 2606 ^a! 2607 2608subrPrinc: arguArray 2609 | a | 2610 a := arguArray at: 1. 2611 (a isKindOf: String) 2612 ifTrue: [textCollector show: a] 2613 ifFalse: [textCollector show: (self printString: a)]. 2614 ^a! 2615 2616subrPrint: arguArray 2617 | a | 2618 a := self subrPrinc: arguArray. 2619 textCollector nl. 2620 ^a! 2621 2622subrPutprop: arguArray 2623 | a1 a2 a3 | 2624 a1 := arguArray at: 1. 2625 a2 := arguArray at: 2. 2626 a3 := arguArray at: 3. 2627 (a1 isKindOf: Symbol) 2628 ifFalse: [^self fatal: 'unexpected argument ' , (self printString: a1) , ' for putprop']. 2629 (a2 isKindOf: Symbol) 2630 ifFalse: [^self fatal: 'unexpected argument ' , (self printString: a2) , ' for putprop']. 2631 ^self 2632 putprop: a1 2633 key: a2 2634 value: a3! 2635 2636subrRemprop: arguArray 2637 | a1 a2 | 2638 a1 := arguArray at: 1. 2639 a2 := arguArray at: 2. 2640 (a1 isKindOf: Symbol) 2641 ifFalse: [^self fatal: 'unexpected argument ' , (self printString: a1) , ' for remprop']. 2642 (a2 isKindOf: Symbol) 2643 ifFalse: [^self fatal: 'unexpected argument ' , (self printString: a2) , ' for remprop']. 2644 ^self remprop: a1 key: a2! 2645 2646subrReverse: arguArray 2647 | a1 | 2648 a1 := arguArray at: 1. 2649 (a1 isKindOf: LispCons) 2650 ifFalse: [^self fatal: 'unexpected argument ' , (self printString: a1) , ' for reverse']. 2651 ^a1 reverse! 2652 2653subrRplaca: arguArray 2654 | a1 a2 | 2655 a1 := arguArray at: 1. 2656 a2 := arguArray at: 2. 2657 (a1 isKindOf: LispCons) 2658 ifFalse: [^self fatal: 'unexpected argument ' , (self printString: a2) , ' for rplaca']. 2659 a1 rplaca: a2. 2660 ^a1! 2661 2662subrRplacd: arguArray 2663 | a1 a2 | 2664 a1 := arguArray at: 1. 2665 a2 := arguArray at: 2. 2666 (a1 isKindOf: LispCons) 2667 ifFalse: [^self fatal: 'unexpected argument ' , (self printString: a2) , ' for rplacd']. 2668 a1 rplacd: a2. 2669 ^a1! 2670 2671subrStringp: arguArray 2672 | a1 | 2673 a1 := arguArray at: 1. 2674 ((a1 isKindOf: String) 2675 and: [(a1 isKindOf: Symbol) not]) 2676 ifTrue: [^#t]. 2677 ^LispNil null! 2678 2679subrSubrs 2680 | list | 2681 list := LispNil null. 2682 self subrOblist reverse do: [:id | (self getprop: id key: #subr) 2683 = LispNil null ifFalse: [list := LispCons head: id tail: list]]. 2684 ^list! 2685 2686subrSymbolp: arguArray 2687 | a1 | 2688 a1 := arguArray at: 1. 2689 (a1 isKindOf: Symbol) ifTrue: [^#t]. 2690 ^LispNil null! 2691 2692subrTerpri 2693 textCollector nl. 2694 ^#t! ! 2695 2696 2697 2698 2699