From 53e6421ce137c5172086bc668a7343b7bb656271 Mon Sep 17 00:00:00 2001 From: Lassi Kortela Date: Fri, 9 Aug 2019 15:02:04 +0300 Subject: [PATCH] Remove curiosity files from tree --- ascii-mona-lisa | 47 -- ascii-mona-lisa-2 | 71 -- llt/UTF8.txt | 212 ------ tiny/Makefile | 23 - tiny/eval1 | 390 ----------- tiny/eval2 | 407 ------------ tiny/evalt | 443 ------------- tiny/flutils.c | 117 ---- tiny/lisp-nontail.c | 1032 ----------------------------- tiny/lisp.c | 1099 ------------------------------- tiny/lisp2.c | 1525 ------------------------------------------- tiny/lispf.c | 1109 ------------------------------- tiny/system.lsp | 426 ------------ todo | 1199 ---------------------------------- todo-scrap | 41 -- 15 files changed, 8141 deletions(-) delete mode 100644 ascii-mona-lisa delete mode 100644 ascii-mona-lisa-2 delete mode 100644 llt/UTF8.txt delete mode 100644 tiny/Makefile delete mode 100644 tiny/eval1 delete mode 100644 tiny/eval2 delete mode 100644 tiny/evalt delete mode 100644 tiny/flutils.c delete mode 100644 tiny/lisp-nontail.c delete mode 100644 tiny/lisp.c delete mode 100644 tiny/lisp2.c delete mode 100644 tiny/lispf.c delete mode 100644 tiny/system.lsp delete mode 100644 todo delete mode 100644 todo-scrap diff --git a/ascii-mona-lisa b/ascii-mona-lisa deleted file mode 100644 index e3e822e..0000000 --- a/ascii-mona-lisa +++ /dev/null @@ -1,47 +0,0 @@ -iIYVVVVXVVVVVVVVVYVYVYYVYYYYIIIIYYYIYVVVYYYYYYYYYVVYVVVVXVVVVVYI+. -tYVXXXXXXVXXXXVVVYVVVVVVVVVVVVYVVVVVVVVVVVVVVVVVXXXXXVXXXXXXXVVYi. -iYXRXRRRXXXXXXXXXXXVVXVXVVVVVVVVXXXVXVVXXXXXXXXXXXXXXRRRRRRRRRXVi. -tVRRRRRRRRRRRRRRRXRXXXXXXXXXXXXXXRRXXXXRRRRXXXXXXXRRRRRRRRRRRRXV+. -tVRRBBBRMBRRRRRRRRRXXRRRRRXt=+;;;;;==iVXRRRRXXXXRRRRRRRRMMBRRRRXi, -tVRRBMBBMMBBBBBMBBRBBBRBX++=++;;;;;;:;;;IRRRRXXRRRBBBBBBMMBBBRRXi, -iVRMMMMMMMMMMMMMMBRBBMMV==iIVYIi=;;;;:::;;XRRRRRRBBMMMMMMMMBBRRXi. -iVRMMMMMMMMMMMMMMMMMMMY;IBWWWWMMXYi=;:::::;RBBBMMMMMMMMMMMMMMBBXi, -+VRMMRBMMMMMMMMMMMMMMY+;VMMMMMMMRXIi=;:::::=VVXXXRRRMMMMMMMMBBMXi; -=tYYVVVXRRRXXRBMMMMMV+;=RBBMMMXVXXVYt;::::::ttYYVYVVRMMMMMMBXXVI+= -;=tIYYVYYYYYYVVVMMMBt=;;+i=IBi+t==;;i;::::::+iitIIttYRMMMMMRXVVI=; -;=IIIIYYYIIIIttIYItIt;;=VVYXBIVRXVVXI;::::::;+iitttttVMMBRRRVVVI+, -;+++tttIttttiiii+i++==;;RMMMBXXMMMXI+;::::::;+ittttitYVXVYYIYVIi;; -;===iiittiiIitiii++;;;;:IVRVi=iBXVIi;::::::::;==+++++iiittii+++=;; -;;==+iiiiiiiiii+++=;;;;;;VYVIiiiVVt+;::::::::;++++++++++iti++++=;; -;;=++iiii+i+++++iii==;;;::tXYIIYIi+=;:::::,::;+++++++++++++++++=;; -;;;+==+ii+++++iiiiit=;;:::::=====;;;::::::::::+++i+++++++++i+++;;; -;;;==+=+iiiiitttIIII+;;;:,::,;;;;:;=;;;::,::::=++++++++==++++++;;; -:;====+tittiiittttti+;;::::,:=Ytiiiiti=;:::::,:;;==ii+ittItii+==;; -;;+iiittIti+ii;;===;;:;::::;+IVXVVVVVVt;;;;;::::;;===;+IIiiti=;;;; -;=++++iIti+ii+=;;;=;:::;;+VXBMMBBBBBBXY=;=;;:::::;=iYVIIttii++;;;; -;;++iiiItttIi+++=;;:::;=iBMMMMMMMMMMMXI==;;,::;;:;;=+itIttIIti+;;; -;=+++++i+tYIIiii;:,::;itXMMMMMMMMMMMBXti==;:;++=;:::::;=+iittti+;; -;;+ii+ii+iitiIi;::::;iXBMMMMMWWWWWMMBXti+ii=;::::,,,,:::=;==+tI+;; -;;iiiitItttti;:::;::=+itYXXMWWWWWWMBYt+;;::,,,,,,,,,,,,,:==;==;;;; -:;=iIIIttIt+:;:::;;;==;+=+iiittttti+;;:,:,,,,::,,,,,,,,:::;=;==::; -;::=+ittiii=;:::::;;;:;:;=++==;;==;:,,,,,,:;::::,,,,,,,,::;==;;::; -:::;+iiiii=;::::,:;:::::;;:;;::;:::,,,,,,,:::;=;;;:,,,,,:::;;::::; -:;;iIIIIII=;:::,:::::::,::::,:::,,,,,,,,,,,:;;=;:,,,,,,::::;=;:::; -:;==++ii+;;;:::::::::::,,,,,,::,,,,,,,,,,,::::,,,,,,,,,,:,:::::::; -::;;=+=;;;:::;;::,,,,,,,,,,,,,,,,,,,,,,,,,:,,,,,,,,,,,,,,,,,:::::; -::;=;;;:;:::;;;;::,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,::,,::::; -:;;:;::::::,::,,:,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,:::; -:::::::::::;;;:,,,,,,,,,,,,,...,...,,,.,,,,,,,,,,,,.,,,,,,,,,,,,:; -::::::::;=;;;;;::,,,,,,,,,,,.......,...,,,,,,,,,,,,.,,,,,,,,,,,,,; -:::::,,:;=;;;;;;;iVXXXVt+:,,....,,,,....,.,,,,,,,.,.....,,,,,,,,:; -:,,::,,:::;;;;;;=IVVVXXXXVXVt:,,,,,..,..,,,,.,,,,,..,.,,,,,,,,,,,; -::,::,,,:,:::::,::;=iIYVXVVVVIYIi;,,.,.,,,::,,,,,,,,,,,,,,,,,,,,,. -:,,,,,,,,,,,,,,,,::;+itIIIIIIi:;;i++=;;;;;;;;;::,,,...,,..,,,,,,,. -:,,,,,,,,,,,,,,=iitVYi++iitt==it;;:;;;;::;;::::,,,......,,,,,,,::. -::,,,,,,,,,,,,,++iiIVIi=;;=;+i;:;+:::,,,,,,,,,,,,,.....,,,,,,,,::, -,,,,,,,,,,,,,,,;=+it=:::,,,,,,,,,,.,......,,.,..........,,,,,,,,:: -:,,,,,,,,,,,,,,,,:=:,,,,,,,,,,,,,,......................,.,,.,.,,: -:,,,,,,,,,,,,,,,,,:,,,,,,,,,,..,........................,..,...,,: -,,,,,,,,,,,,,,,,,,,.....................................,.......,, -,,,,,,,,,.,,,,,,,...............................................,, -itittiiiii+=++=;;=iiiiiiittiiiiii+iii===;++iiitiiiiiii+=====+ii=+i diff --git a/ascii-mona-lisa-2 b/ascii-mona-lisa-2 deleted file mode 100644 index 78e5519..0000000 --- a/ascii-mona-lisa-2 +++ /dev/null @@ -1,71 +0,0 @@ -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!>'''''' !!!!! -!!!!! ?$$$$$$$$$$$$??$c`$$$$$$$$$$$?>' `!!!! -!!!!! `?$$$$$$I7?"" ,$$$$$$$$$?>>' !!!! -!!!!!. <>'' `!!! -!!!!!! '' `!!! -!!!!!! $$$hccccccccc= cc$$$$$$$>>' !!! -!!!!! `?$$$$$$F"""" `"$$$$$>>>'' `!! -!!!!! "?$$$$$cccccc$$$$??>>>>' !! -!!!!> "$$$$$$$$$$$$$F>>>>'' `! -!!!!! "$$$$$$$$???>''' ! -!!!!!> `""""" ` -!!!!!!; . ` -!!!!!!! ?h. -!!!!!!!! $$c, -!!!!!!!!> ?$$$h. .,c -!!!!!!!!! $$$$$$$$$hc,.,,cc$$$$$ -!!!!!!!!! .,zcc$$$$$$$$$$$$$$$$$$$$$$ -!!!!!!!!! .z$$$$$$$$$$$$$$$$$$$$$$$$$$$$ -!!!!!!!!! ,d$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ . -!!!!!!!!! ,d$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ !! -!!!!!!!!! ,d$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ ,!' -!!!!!!!!> c$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$. !' -!!!!!!'' ,d$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$> ' -!!!'' z$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$> -!' ,$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$> .. - z$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$' ;!!!!''` - $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$F ,;;!'`' .'' - <$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$> ,;'`' ,; - `$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$F -' ,;!!' - "?$$$$$$$$$$?$$$$$$$$$$$$$$$$$$$$$$$$$$F . ""??$$$?C3$$$$$$$$$$$$$$$$$$$$$$$$"" ;!''' !!! - ;!!!!;, `"''""????$$$$$$$$$$$$$$$$"" ,;-'' ',! - ;!!!!;,;, .. ' . ' ' - !!' ,;!!! ;'`!!!!!!!!;!!!!!; . >' .'' ; - !!' ;!!'!';! !! !!!!!!!!!!!!! ' -' - ;! ;> - !' ; !! ' - ' ;! > ! ' - ' -by Allen Mullen diff --git a/llt/UTF8.txt b/llt/UTF8.txt deleted file mode 100644 index 4363f27..0000000 --- a/llt/UTF8.txt +++ /dev/null @@ -1,212 +0,0 @@ - -UTF-8 encoded sample plain-text file -‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾ - -Markus Kuhn [ˈmaʳkʊs kuːn] — 2002-07-25 - - -The ASCII compatible UTF-8 encoding used in this plain-text file -is defined in Unicode, ISO 10646-1, and RFC 2279. - - -Using Unicode/UTF-8, you can write in emails and source code things such as - -Mathematics and sciences: - - ∮ E⋅da = Q, n → ∞, ∑ f(i) = ∏ g(i), ⎧⎡⎛┌─────┐⎞⎤⎫ - ⎪⎢⎜│a²+b³ ⎟⎥⎪ - ∀x∈ℝ: ⌈x⌉ = −⌊−x⌋, α ∧ ¬β = ¬(¬α ∨ β), ⎪⎢⎜│───── ⎟⎥⎪ - ⎪⎢⎜⎷ c₈ ⎟⎥⎪ - ℕ ⊆ ℕ₀ ⊂ ℤ ⊂ ℚ ⊂ ℝ ⊂ ℂ, ⎨⎢⎜ ⎟⎥⎬ - ⎪⎢⎜ ∞ ⎟⎥⎪ - ⊥ < a ≠ b ≡ c ≤ d ≪ ⊤ ⇒ (⟦A⟧ ⇔ ⟪B⟫), ⎪⎢⎜ ⎲ ⎟⎥⎪ - ⎪⎢⎜ ⎳aⁱ-bⁱ⎟⎥⎪ - 2H₂ + O₂ ⇌ 2H₂O, R = 4.7 kΩ, ⌀ 200 mm ⎩⎣⎝i=1 ⎠⎦⎭ - -Linguistics and dictionaries: - - ði ıntəˈnæʃənəl fəˈnɛtık əsoʊsiˈeıʃn - Y [ˈʏpsilɔn], Yen [jɛn], Yoga [ˈjoːgɑ] - -APL: - - ((V⍳V)=⍳⍴V)/V←,V ⌷←⍳→⍴∆∇⊃‾⍎⍕⌈ - -Nicer typography in plain text files: - - ╔══════════════════════════════════════════╗ - ║ ║ - ║ • ‘single’ and “double” quotes ║ - ║ ║ - ║ • Curly apostrophes: “We’ve been here” ║ - ║ ║ - ║ • Latin-1 apostrophe and accents: '´` ║ - ║ ║ - ║ • ‚deutsche‘ „Anführungszeichen“ ║ - ║ ║ - ║ • †, ‡, ‰, •, 3–4, —, −5/+5, ™, … ║ - ║ ║ - ║ • ASCII safety test: 1lI|, 0OD, 8B ║ - ║ ╭─────────╮ ║ - ║ • the euro symbol: │ 14.95 € │ ║ - ║ ╰─────────╯ ║ - ╚══════════════════════════════════════════╝ - -Combining characters: - - STARGΛ̊TE SG-1, a = v̇ = r̈, a⃑ ⊥ b⃑ - -Greek (in Polytonic): - - The Greek anthem: - - Σὲ γνωρίζω ἀπὸ τὴν κόψη - τοῦ σπαθιοῦ τὴν τρομερή, - σὲ γνωρίζω ἀπὸ τὴν ὄψη - ποὺ μὲ βία μετράει τὴ γῆ. - - ᾿Απ᾿ τὰ κόκκαλα βγαλμένη - τῶν ῾Ελλήνων τὰ ἱερά - καὶ σὰν πρῶτα ἀνδρειωμένη - χαῖρε, ὦ χαῖρε, ᾿Ελευθεριά! - - From a speech of Demosthenes in the 4th century BC: - - Οὐχὶ ταὐτὰ παρίσταταί μοι γιγνώσκειν, ὦ ἄνδρες ᾿Αθηναῖοι, - ὅταν τ᾿ εἰς τὰ πράγματα ἀποβλέψω καὶ ὅταν πρὸς τοὺς - λόγους οὓς ἀκούω· τοὺς μὲν γὰρ λόγους περὶ τοῦ - τιμωρήσασθαι Φίλιππον ὁρῶ γιγνομένους, τὰ δὲ πράγματ᾿ - εἰς τοῦτο προήκοντα, ὥσθ᾿ ὅπως μὴ πεισόμεθ᾿ αὐτοὶ - πρότερον κακῶς σκέψασθαι δέον. οὐδέν οὖν ἄλλο μοι δοκοῦσιν - οἱ τὰ τοιαῦτα λέγοντες ἢ τὴν ὑπόθεσιν, περὶ ἧς βουλεύεσθαι, - οὐχὶ τὴν οὖσαν παριστάντες ὑμῖν ἁμαρτάνειν. ἐγὼ δέ, ὅτι μέν - ποτ᾿ ἐξῆν τῇ πόλει καὶ τὰ αὑτῆς ἔχειν ἀσφαλῶς καὶ Φίλιππον - τιμωρήσασθαι, καὶ μάλ᾿ ἀκριβῶς οἶδα· ἐπ᾿ ἐμοῦ γάρ, οὐ πάλαι - γέγονεν ταῦτ᾿ ἀμφότερα· νῦν μέντοι πέπεισμαι τοῦθ᾿ ἱκανὸν - προλαβεῖν ἡμῖν εἶναι τὴν πρώτην, ὅπως τοὺς συμμάχους - σώσομεν. ἐὰν γὰρ τοῦτο βεβαίως ὑπάρξῃ, τότε καὶ περὶ τοῦ - τίνα τιμωρήσεταί τις καὶ ὃν τρόπον ἐξέσται σκοπεῖν· πρὶν δὲ - τὴν ἀρχὴν ὀρθῶς ὑποθέσθαι, μάταιον ἡγοῦμαι περὶ τῆς - τελευτῆς ὁντινοῦν ποιεῖσθαι λόγον. - - Δημοσθένους, Γ´ ᾿Ολυνθιακὸς - -Georgian: - - From a Unicode conference invitation: - - გთხოვთ ახლავე გაიაროთ რეგისტრაცია Unicode-ის მეათე საერთაშორისო - კონფერენციაზე დასასწრებად, რომელიც გაიმართება 10-12 მარტს, - ქ. მაინცში, გერმანიაში. კონფერენცია შეჰკრებს ერთად მსოფლიოს - ექსპერტებს ისეთ დარგებში როგორიცაა ინტერნეტი და Unicode-ი, - ინტერნაციონალიზაცია და ლოკალიზაცია, Unicode-ის გამოყენება - ოპერაციულ სისტემებსა, და გამოყენებით პროგრამებში, შრიფტებში, - ტექსტების დამუშავებასა და მრავალენოვან კომპიუტერულ სისტემებში. - -Russian: - - From a Unicode conference invitation: - - Зарегистрируйтесь сейчас на Десятую Международную Конференцию по - Unicode, которая состоится 10-12 марта 1997 года в Майнце в Германии. - Конференция соберет широкий круг экспертов по вопросам глобального - Интернета и Unicode, локализации и интернационализации, воплощению и - применению Unicode в различных операционных системах и программных - приложениях, шрифтах, верстке и многоязычных компьютерных системах. - -Thai (UCS Level 2): - - Excerpt from a poetry on The Romance of The Three Kingdoms (a Chinese - classic 'San Gua'): - - [----------------------------|------------------------] - ๏ แผ่นดินฮั่นเสื่อมโทรมแสนสังเวช พระปกเกศกองบู๊กู้ขึ้นใหม่ - สิบสองกษัตริย์ก่อนหน้าแลถัดไป สององค์ไซร้โง่เขลาเบาปัญญา - ทรงนับถือขันทีเป็นที่พึ่ง บ้านเมืองจึงวิปริตเป็นนักหนา - โฮจิ๋นเรียกทัพทั่วหัวเมืองมา หมายจะฆ่ามดชั่วตัวสำคัญ - เหมือนขับไสไล่เสือจากเคหา รับหมาป่าเข้ามาเลยอาสัญ - ฝ่ายอ้องอุ้นยุแยกให้แตกกัน ใช้สาวนั้นเป็นชนวนชื่นชวนใจ - พลันลิฉุยกุยกีกลับก่อเหตุ ช่างอาเพศจริงหนาฟ้าร้องไห้ - ต้องรบราฆ่าฟันจนบรรลัย ฤๅหาใครค้ำชูกู้บรรลังก์ ฯ - - (The above is a two-column text. If combining characters are handled - correctly, the lines of the second column should be aligned with the - | character above.) - -Ethiopian: - - Proverbs in the Amharic language: - - ሰማይ አይታረስ ንጉሥ አይከሰስ። - ብላ ካለኝ እንደአባቴ በቆመጠኝ። - ጌጥ ያለቤቱ ቁምጥና ነው። - ደሀ በሕልሙ ቅቤ ባይጠጣ ንጣት በገደለው። - የአፍ ወለምታ በቅቤ አይታሽም። - አይጥ በበላ ዳዋ ተመታ። - ሲተረጉሙ ይደረግሙ። - ቀስ በቀስ፥ ዕንቁላል በእግሩ ይሄዳል። - ድር ቢያብር አንበሳ ያስር። - ሰው እንደቤቱ እንጅ እንደ ጉረቤቱ አይተዳደርም። - እግዜር የከፈተውን ጉሮሮ ሳይዘጋው አይድርም። - የጎረቤት ሌባ፥ ቢያዩት ይስቅ ባያዩት ያጠልቅ። - ሥራ ከመፍታት ልጄን ላፋታት። - ዓባይ ማደሪያ የለው፥ ግንድ ይዞ ይዞራል። - የእስላም አገሩ መካ የአሞራ አገሩ ዋርካ። - ተንጋሎ ቢተፉ ተመልሶ ባፉ። - ወዳጅህ ማር ቢሆን ጨርስህ አትላሰው። - እግርህን በፍራሽህ ልክ ዘርጋ። - -Runes: - - ᚻᛖ ᚳᚹᚫᚦ ᚦᚫᛏ ᚻᛖ ᛒᚢᛞᛖ ᚩᚾ ᚦᚫᛗ ᛚᚪᚾᛞᛖ ᚾᚩᚱᚦᚹᛖᚪᚱᛞᚢᛗ ᚹᛁᚦ ᚦᚪ ᚹᛖᛥᚫ - - (Old English, which transcribed into Latin reads 'He cwaeth that he - bude thaem lande northweardum with tha Westsae.' and means 'He said - that he lived in the northern land near the Western Sea.') - -Braille: - - ⡌⠁⠧⠑ ⠼⠁⠒ ⡍⠜⠇⠑⠹⠰⠎ ⡣⠕⠌ - - ⡍⠜⠇⠑⠹ ⠺⠁⠎ ⠙⠑⠁⠙⠒ ⠞⠕ ⠃⠑⠛⠔ ⠺⠊⠹⠲ ⡹⠻⠑ ⠊⠎ ⠝⠕ ⠙⠳⠃⠞ - ⠱⠁⠞⠑⠧⠻ ⠁⠃⠳⠞ ⠹⠁⠞⠲ ⡹⠑ ⠗⠑⠛⠊⠌⠻ ⠕⠋ ⠙⠊⠎ ⠃⠥⠗⠊⠁⠇ ⠺⠁⠎ - ⠎⠊⠛⠝⠫ ⠃⠹ ⠹⠑ ⠊⠇⠻⠛⠹⠍⠁⠝⠂ ⠹⠑ ⠊⠇⠻⠅⠂ ⠹⠑ ⠥⠝⠙⠻⠞⠁⠅⠻⠂ - ⠁⠝⠙ ⠹⠑ ⠡⠊⠑⠋ ⠍⠳⠗⠝⠻⠲ ⡎⠊⠗⠕⠕⠛⠑ ⠎⠊⠛⠝⠫ ⠊⠞⠲ ⡁⠝⠙ - ⡎⠊⠗⠕⠕⠛⠑⠰⠎ ⠝⠁⠍⠑ ⠺⠁⠎ ⠛⠕⠕⠙ ⠥⠏⠕⠝ ⠰⡡⠁⠝⠛⠑⠂ ⠋⠕⠗ ⠁⠝⠹⠹⠔⠛ ⠙⠑ - ⠡⠕⠎⠑ ⠞⠕ ⠏⠥⠞ ⠙⠊⠎ ⠙⠁⠝⠙ ⠞⠕⠲ - - ⡕⠇⠙ ⡍⠜⠇⠑⠹ ⠺⠁⠎ ⠁⠎ ⠙⠑⠁⠙ ⠁⠎ ⠁ ⠙⠕⠕⠗⠤⠝⠁⠊⠇⠲ - - ⡍⠔⠙⠖ ⡊ ⠙⠕⠝⠰⠞ ⠍⠑⠁⠝ ⠞⠕ ⠎⠁⠹ ⠹⠁⠞ ⡊ ⠅⠝⠪⠂ ⠕⠋ ⠍⠹ - ⠪⠝ ⠅⠝⠪⠇⠫⠛⠑⠂ ⠱⠁⠞ ⠹⠻⠑ ⠊⠎ ⠏⠜⠞⠊⠊⠥⠇⠜⠇⠹ ⠙⠑⠁⠙ ⠁⠃⠳⠞ - ⠁ ⠙⠕⠕⠗⠤⠝⠁⠊⠇⠲ ⡊ ⠍⠊⠣⠞ ⠙⠁⠧⠑ ⠃⠑⠲ ⠔⠊⠇⠔⠫⠂ ⠍⠹⠎⠑⠇⠋⠂ ⠞⠕ - ⠗⠑⠛⠜⠙ ⠁ ⠊⠕⠋⠋⠔⠤⠝⠁⠊⠇ ⠁⠎ ⠹⠑ ⠙⠑⠁⠙⠑⠌ ⠏⠊⠑⠊⠑ ⠕⠋ ⠊⠗⠕⠝⠍⠕⠝⠛⠻⠹ - ⠔ ⠹⠑ ⠞⠗⠁⠙⠑⠲ ⡃⠥⠞ ⠹⠑ ⠺⠊⠎⠙⠕⠍ ⠕⠋ ⠳⠗ ⠁⠝⠊⠑⠌⠕⠗⠎ - ⠊⠎ ⠔ ⠹⠑ ⠎⠊⠍⠊⠇⠑⠆ ⠁⠝⠙ ⠍⠹ ⠥⠝⠙⠁⠇⠇⠪⠫ ⠙⠁⠝⠙⠎ - ⠩⠁⠇⠇ ⠝⠕⠞ ⠙⠊⠌⠥⠗⠃ ⠊⠞⠂ ⠕⠗ ⠹⠑ ⡊⠳⠝⠞⠗⠹⠰⠎ ⠙⠕⠝⠑ ⠋⠕⠗⠲ ⡹⠳ - ⠺⠊⠇⠇ ⠹⠻⠑⠋⠕⠗⠑ ⠏⠻⠍⠊⠞ ⠍⠑ ⠞⠕ ⠗⠑⠏⠑⠁⠞⠂ ⠑⠍⠏⠙⠁⠞⠊⠊⠁⠇⠇⠹⠂ ⠹⠁⠞ - ⡍⠜⠇⠑⠹ ⠺⠁⠎ ⠁⠎ ⠙⠑⠁⠙ ⠁⠎ ⠁ ⠙⠕⠕⠗⠤⠝⠁⠊⠇⠲ - - (The first couple of paragraphs of "A Christmas Carol" by Dickens) - -Compact font selection example text: - - ABCDEFGHIJKLMNOPQRSTUVWXYZ /0123456789 - abcdefghijklmnopqrstuvwxyz £©µÀÆÖÞßéöÿ - –—‘“”„†•…‰™œŠŸž€ ΑΒΓΔΩαβγδω АБВГДабвгд - ∀∂∈ℝ∧∪≡∞ ↑↗↨↻⇣ ┐┼╔╘░►☺♀ fi�⑀₂ἠḂӥẄɐː⍎אԱა - -Greetings in various languages: - - Hello world, Καλημέρα κόσμε, コンニチハ - -Box drawing alignment tests: █ - ▉ - ╔══╦══╗ ┌──┬──┐ ╭──┬──╮ ╭──┬──╮ ┏━━┳━━┓ ┎┒┏┑ ╷ ╻ ┏┯┓ ┌┰┐ ▊ ╱╲╱╲╳╳╳ - ║┌─╨─┐║ │╔═╧═╗│ │╒═╪═╕│ │╓─╁─╖│ ┃┌─╂─┐┃ ┗╃╄┙ ╶┼╴╺╋╸┠┼┨ ┝╋┥ ▋ ╲╱╲╱╳╳╳ - ║│╲ ╱│║ │║ ║│ ││ │ ││ │║ ┃ ║│ ┃│ ╿ │┃ ┍╅╆┓ ╵ ╹ ┗┷┛ └┸┘ ▌ ╱╲╱╲╳╳╳ - ╠╡ ╳ ╞╣ ├╢ ╟┤ ├┼─┼─┼┤ ├╫─╂─╫┤ ┣┿╾┼╼┿┫ ┕┛┖┚ ┌┄┄┐ ╎ ┏┅┅┓ ┋ ▍ ╲╱╲╱╳╳╳ - ║│╱ ╲│║ │║ ║│ ││ │ ││ │║ ┃ ║│ ┃│ ╽ │┃ ░░▒▒▓▓██ ┊ ┆ ╎ ╏ ┇ ┋ ▎ - ║└─╥─┘║ │╚═╤═╝│ │╘═╪═╛│ │╙─╀─╜│ ┃└─╂─┘┃ ░░▒▒▓▓██ ┊ ┆ ╎ ╏ ┇ ┋ ▏ - ╚══╩══╝ └──┴──┘ ╰──┴──╯ ╰──┴──╯ ┗━━┻━━┛ ▗▄▖▛▀▜ └╌╌┘ ╎ ┗╍╍┛ ┋ ▁▂▃▄▅▆▇█ - ▝▀▘▙▄▟ diff --git a/tiny/Makefile b/tiny/Makefile deleted file mode 100644 index f3971dd..0000000 --- a/tiny/Makefile +++ /dev/null @@ -1,23 +0,0 @@ -FREEBSD-GE-10 = $(shell test `uname` = FreeBSD -a `uname -r | cut -d. -f1` -ge 10 && echo YES) -CC = $(if $(FREEBSD-GE-10),clang,gcc) - -NAME = lisp -SRC = $(NAME).c -EXENAME = $(NAME) - -FLAGS = -Wall -Wextra -LIBS = - -DEBUGFLAGS = -g -DDEBUG $(FLAGS) -SHIPFLAGS = -O3 -fomit-frame-pointer $(FLAGS) - -default: release - -debug: $(SRC) - $(CC) $(DEBUGFLAGS) $(SRC) -o $(EXENAME) $(LIBS) - -release: $(SRC) - $(CC) $(SHIPFLAGS) $(SRC) -o $(EXENAME) $(LIBS) - -clean: - rm -f $(EXENAME) diff --git a/tiny/eval1 b/tiny/eval1 deleted file mode 100644 index d7140c2..0000000 --- a/tiny/eval1 +++ /dev/null @@ -1,390 +0,0 @@ -value_t eval_sexpr(value_t e, value_t *penv) -{ - value_t f, v, bind, headsym, asym, labl=0, *pv, *argsyms, *body, *lenv; - value_t *rest; - cons_t *c; - symbol_t *sym; - u_int32_t saveSP; - int i, nargs, noeval=0; - number_t s, n; - - if (issymbol(e)) { - sym = (symbol_t*)ptr(e); - if (sym->constant != UNBOUND) return sym->constant; - v = *penv; - while (iscons(v)) { - bind = car_(v); - if (iscons(bind) && car_(bind) == e) - return cdr_(bind); - v = cdr_(v); - } - if ((v = sym->binding) == UNBOUND) - lerror("eval: error: variable %s has no value\n", sym->name); - return v; - } - if ((unsigned)(char*)&nargs < (unsigned)stack_bottom || SP>=(N_STACK-100)) - lerror("eval: error: stack overflow\n"); - saveSP = SP; - PUSH(e); - f = eval(car_(e), penv); - if (isbuiltin(f)) { - // handle builtin function - if (!isspecial(f)) { - // evaluate argument list, placing arguments on stack - v = Stack[saveSP] = cdr_(Stack[saveSP]); - while (iscons(v)) { - v = eval(car_(v), penv); - PUSH(v); - v = Stack[saveSP] = cdr_(Stack[saveSP]); - } - } - apply_builtin: - nargs = SP - saveSP - 1; - switch (intval(f)) { - // special forms - case F_QUOTE: - v = cdr_(Stack[saveSP]); - if (!iscons(v)) - lerror("quote: error: expected argument\n"); - v = car_(v); - break; - case F_MACRO: - case F_LAMBDA: - v = Stack[saveSP]; - if (*penv != NIL) { - // build a closure (lambda args body . env) - v = cdr_(v); - PUSH(car(v)); - argsyms = &Stack[SP-1]; - PUSH(car(cdr_(v))); - body = &Stack[SP-1]; - v = cons_(intval(f)==F_LAMBDA ? &LAMBDA : &MACRO, - cons(argsyms, cons(body, penv))); - } - break; - case F_LABEL: - v = Stack[saveSP]; - if (*penv != NIL) { - v = cdr_(v); - PUSH(car(v)); // name - pv = &Stack[SP-1]; - PUSH(car(cdr_(v))); // function - body = &Stack[SP-1]; - *body = eval(*body, penv); // evaluate lambda - v = cons_(&LABEL, cons(pv, cons(body, &NIL))); - } - break; - case F_IF: - v = car(cdr_(Stack[saveSP])); - if (eval(v, penv) != NIL) - v = car(cdr_(cdr_(Stack[saveSP]))); - else - v = car(cdr(cdr_(cdr_(Stack[saveSP])))); - v = eval(v, penv); - break; - case F_COND: - Stack[saveSP] = cdr_(Stack[saveSP]); - pv = &Stack[saveSP]; v = NIL; - while (iscons(*pv)) { - c = tocons(car_(*pv), "cond"); - if ((v=eval(c->car, penv)) != NIL) { - *pv = cdr_(car_(*pv)); - // evaluate body forms - while (iscons(*pv)) { - v = eval(car_(*pv), penv); - *pv = cdr_(*pv); - } - break; - } - *pv = cdr_(*pv); - } - break; - case F_AND: - Stack[saveSP] = cdr_(Stack[saveSP]); - pv = &Stack[saveSP]; v = T; - while (iscons(*pv)) { - if ((v=eval(car_(*pv), penv)) == NIL) - break; - *pv = cdr_(*pv); - } - break; - case F_OR: - Stack[saveSP] = cdr_(Stack[saveSP]); - pv = &Stack[saveSP]; v = NIL; - while (iscons(*pv)) { - if ((v=eval(car_(*pv), penv)) != NIL) - break; - *pv = cdr_(*pv); - } - break; - case F_WHILE: - PUSH(car(cdr(cdr_(Stack[saveSP])))); - body = &Stack[SP-1]; - Stack[saveSP] = car_(cdr_(Stack[saveSP])); - value_t *cond = &Stack[saveSP]; - PUSH(NIL); pv = &Stack[SP-1]; - while (eval(*cond, penv) != NIL) - *pv = eval(*body, penv); - v = *pv; - break; - case F_PROGN: - // return last arg - Stack[saveSP] = cdr_(Stack[saveSP]); - pv = &Stack[saveSP]; v = NIL; - while (iscons(*pv)) { - v = eval(car_(*pv), penv); - *pv = cdr_(*pv); - } - break; - - // ordinary functions - case F_SET: - argcount("set", nargs, 2); - e = Stack[SP-2]; - v = *penv; - while (iscons(v)) { - bind = car_(v); - if (iscons(bind) && car_(bind) == e) { - cdr_(bind) = (v=Stack[SP-1]); - SP=saveSP; return v; - } - v = cdr_(v); - } - tosymbol(e, "set")->binding = (v=Stack[SP-1]); - break; - case F_BOUNDP: - argcount("boundp", nargs, 1); - if (tosymbol(Stack[SP-1], "boundp")->binding == UNBOUND) - v = NIL; - else - v = T; - break; - case F_EQ: - argcount("eq", nargs, 2); - v = ((Stack[SP-2] == Stack[SP-1]) ? T : NIL); - break; - case F_CONS: - argcount("cons", nargs, 2); - v = mk_cons(); - car_(v) = Stack[SP-2]; - cdr_(v) = Stack[SP-1]; - break; - case F_CAR: - argcount("car", nargs, 1); - v = car(Stack[SP-1]); - break; - case F_CDR: - argcount("cdr", nargs, 1); - v = cdr(Stack[SP-1]); - break; - case F_RPLACA: - argcount("rplaca", nargs, 2); - car(v=Stack[SP-2]) = Stack[SP-1]; - break; - case F_RPLACD: - argcount("rplacd", nargs, 2); - cdr(v=Stack[SP-2]) = Stack[SP-1]; - break; - case F_ATOM: - argcount("atom", nargs, 1); - v = ((!iscons(Stack[SP-1])) ? T : NIL); - break; - case F_SYMBOLP: - argcount("symbolp", nargs, 1); - v = ((issymbol(Stack[SP-1])) ? T : NIL); - break; - case F_NUMBERP: - argcount("numberp", nargs, 1); - v = ((isnumber(Stack[SP-1])) ? T : NIL); - break; - case F_ADD: - s = 0; - for (i=saveSP+1; i < (int)SP; i++) { - n = tonumber(Stack[i], "+"); - s += n; - } - v = number(s); - break; - case F_SUB: - if (nargs < 1) - lerror("-: error: too few arguments\n"); - i = saveSP+1; - s = (nargs==1) ? 0 : tonumber(Stack[i++], "-"); - for (; i < (int)SP; i++) { - n = tonumber(Stack[i], "-"); - s -= n; - } - v = number(s); - break; - case F_MUL: - s = 1; - for (i=saveSP+1; i < (int)SP; i++) { - n = tonumber(Stack[i], "*"); - s *= n; - } - v = number(s); - break; - case F_DIV: - if (nargs < 1) - lerror("/: error: too few arguments\n"); - i = saveSP+1; - s = (nargs==1) ? 1 : tonumber(Stack[i++], "/"); - for (; i < (int)SP; i++) { - n = tonumber(Stack[i], "/"); - if (n == 0) - lerror("/: error: division by zero\n"); - s /= n; - } - v = number(s); - break; - case F_LT: - argcount("<", nargs, 2); - if (tonumber(Stack[SP-2],"<") < tonumber(Stack[SP-1],"<")) - v = T; - else - v = NIL; - break; - case F_NOT: - argcount("not", nargs, 1); - v = ((Stack[SP-1] == NIL) ? T : NIL); - break; - case F_EVAL: - argcount("eval", nargs, 1); - v = eval(Stack[SP-1], &NIL); - break; - case F_PRINT: - for (i=saveSP+1; i < (int)SP; i++) - print(stdout, v=Stack[i]); - break; - case F_READ: - argcount("read", nargs, 0); - v = read_sexpr(stdin); - break; - case F_LOAD: - argcount("load", nargs, 1); - v = load_file(tosymbol(Stack[SP-1], "load")->name); - break; - case F_PROG1: - // return first arg - if (nargs < 1) - lerror("prog1: error: too few arguments\n"); - v = Stack[saveSP+1]; - break; - case F_APPLY: - // unpack a list onto the stack - argcount("apply", nargs, 2); - v = Stack[saveSP] = Stack[SP-1]; // second arg is new arglist - f = Stack[SP-2]; // first arg is new function - POPN(2); // pop apply's args - if (isbuiltin(f)) { - if (isspecial(f)) - lerror("apply: error: cannot apply special operator " - "%s\n", builtin_names[intval(f)]); - while (iscons(v)) { - PUSH(car_(v)); - v = cdr_(v); - } - goto apply_builtin; - } - noeval = 1; - goto apply_lambda; - } - SP = saveSP; - return v; - } - else { - v = Stack[saveSP] = cdr_(Stack[saveSP]); - } - apply_lambda: - if (iscons(f)) { - headsym = car_(f); - if (headsym == LABEL) { - // (label name (lambda ...)) behaves the same as the lambda - // alone, except with name bound to the whole label expression - labl = f; - f = car(cdr(cdr_(labl))); - headsym = car(f); - } - // apply lambda or macro expression - PUSH(cdr(cdr(cdr_(f)))); - lenv = &Stack[SP-1]; - PUSH(car_(cdr_(f))); - argsyms = &Stack[SP-1]; - PUSH(car_(cdr_(cdr_(f)))); - body = &Stack[SP-1]; - if (labl) { - // add label binding to environment - PUSH(labl); - PUSH(car_(cdr_(labl))); - *lenv = cons_(cons(&Stack[SP-1], &Stack[SP-2]), lenv); - POPN(3); - v = Stack[saveSP]; // refetch arglist - } - if (headsym == MACRO) - noeval = 1; - else if (headsym != LAMBDA) - lerror("apply: error: head must be lambda, macro, or label\n"); - // build a calling environment for the lambda - // the environment is the argument binds on top of the captured - // environment - while (iscons(v)) { - // bind args - if (!iscons(*argsyms)) { - if (*argsyms == NIL) - lerror("apply: error: too many arguments\n"); - break; - } - asym = car_(*argsyms); - if (!issymbol(asym)) - lerror("apply: error: formal argument not a symbol\n"); - v = car_(v); - if (!noeval) v = eval(v, penv); - PUSH(v); - *lenv = cons_(cons(&asym, &Stack[SP-1]), lenv); - POPN(2); - *argsyms = cdr_(*argsyms); - v = Stack[saveSP] = cdr_(Stack[saveSP]); - } - if (*argsyms != NIL) { - if (issymbol(*argsyms)) { - if (noeval) { - *lenv = cons_(cons(argsyms, &Stack[saveSP]), lenv); - } - else { - PUSH(NIL); - PUSH(NIL); - rest = &Stack[SP-1]; - // build list of rest arguments - // we have to build it forwards, which is tricky - while (iscons(v)) { - v = eval(car_(v), penv); - PUSH(v); - v = cons_(&Stack[SP-1], &NIL); - POP(); - if (iscons(*rest)) - cdr_(*rest) = v; - else - Stack[SP-2] = v; - *rest = v; - v = Stack[saveSP] = cdr_(Stack[saveSP]); - } - *lenv = cons_(cons(argsyms, &Stack[SP-2]), lenv); - } - } - else if (iscons(*argsyms)) { - lerror("apply: error: too few arguments\n"); - } - } - SP = saveSP; // free temporary stack space - PUSH(*lenv); // preserve environment on stack - lenv = &Stack[SP-1]; - v = eval(*body, lenv); - POP(); - // macro: evaluate expansion in the calling environment - if (headsym == MACRO) - return eval(v, penv); - return v; - } - type_error("apply", "function", f); - return NIL; -} diff --git a/tiny/eval2 b/tiny/eval2 deleted file mode 100644 index c663a8c..0000000 --- a/tiny/eval2 +++ /dev/null @@ -1,407 +0,0 @@ -value_t eval_sexpr(value_t e, value_t *penv) -{ - value_t f, v, bind, headsym, asym, labl=0, *pv, *argsyms, *body, *lenv; - value_t *rest; - cons_t *c; - symbol_t *sym; - u_int32_t saveSP; - int i, nargs, noeval=0; - number_t s, n; - - if (issymbol(e)) { - sym = (symbol_t*)ptr(e); - if (sym->constant != UNBOUND) return sym->constant; - v = *penv; - while (iscons(v)) { - bind = car_(v); - if (iscons(bind) && car_(bind) == e) - return cdr_(bind); - v = cdr_(v); - } - if ((v = sym->binding) == UNBOUND) - lerror("eval: error: variable %s has no value\n", sym->name); - return v; - } - if ((unsigned)(char*)&nargs < (unsigned)stack_bottom || SP>=(N_STACK-100)) - lerror("eval: error: stack overflow\n"); - saveSP = SP; - PUSH(e); - f = eval(car_(e), penv); - if (isbuiltin(f)) { - // handle builtin function - if (!isspecial(f)) { - // evaluate argument list, placing arguments on stack - v = Stack[saveSP] = cdr_(Stack[saveSP]); - while (iscons(v)) { - v = eval(car_(v), penv); - PUSH(v); - v = Stack[saveSP] = cdr_(Stack[saveSP]); - } - } - apply_builtin: - nargs = SP - saveSP - 1; - switch (intval(f)) { - // special forms - case F_QUOTE: - v = cdr_(Stack[saveSP]); - if (!iscons(v)) - lerror("quote: error: expected argument\n"); - v = car_(v); - break; - case F_MACRO: - case F_LAMBDA: - v = Stack[saveSP]; - if (*penv != NIL) { - // build a closure (lambda args body . env) - v = cdr_(v); - PUSH(car(v)); - argsyms = &Stack[SP-1]; - PUSH(car(cdr_(v))); - body = &Stack[SP-1]; - v = cons_(intval(f)==F_LAMBDA ? &LAMBDA : &MACRO, - cons(argsyms, cons(body, penv))); - } - break; - case F_LABEL: - v = Stack[saveSP]; - if (*penv != NIL) { - v = cdr_(v); - PUSH(car(v)); // name - pv = &Stack[SP-1]; - PUSH(car(cdr_(v))); // function - body = &Stack[SP-1]; - *body = eval(*body, penv); // evaluate lambda - v = cons_(&LABEL, cons(pv, cons(body, &NIL))); - } - break; - case F_IF: - v = car(cdr_(Stack[saveSP])); - if (eval(v, penv) != NIL) - v = car(cdr_(cdr_(Stack[saveSP]))); - else - v = car(cdr(cdr_(cdr_(Stack[saveSP])))); - v = eval(v, penv); - break; - case F_COND: - Stack[saveSP] = cdr_(Stack[saveSP]); - pv = &Stack[saveSP]; v = NIL; - while (iscons(*pv)) { - c = tocons(car_(*pv), "cond"); - if ((v=eval(c->car, penv)) != NIL) { - *pv = cdr_(car_(*pv)); - // evaluate body forms - while (iscons(*pv)) { - v = eval(car_(*pv), penv); - *pv = cdr_(*pv); - } - break; - } - *pv = cdr_(*pv); - } - break; - case F_AND: - Stack[saveSP] = cdr_(Stack[saveSP]); - pv = &Stack[saveSP]; v = T; - while (iscons(*pv)) { - if ((v=eval(car_(*pv), penv)) == NIL) - break; - *pv = cdr_(*pv); - } - break; - case F_OR: - Stack[saveSP] = cdr_(Stack[saveSP]); - pv = &Stack[saveSP]; v = NIL; - while (iscons(*pv)) { - if ((v=eval(car_(*pv), penv)) != NIL) - break; - *pv = cdr_(*pv); - } - break; - case F_WHILE: - PUSH(car(cdr(cdr_(Stack[saveSP])))); - body = &Stack[SP-1]; - Stack[saveSP] = car_(cdr_(Stack[saveSP])); - value_t *cond = &Stack[saveSP]; - PUSH(NIL); pv = &Stack[SP-1]; - while (eval(*cond, penv) != NIL) - *pv = eval(*body, penv); - v = *pv; - break; - case F_PROGN: - // return last arg - Stack[saveSP] = cdr_(Stack[saveSP]); - pv = &Stack[saveSP]; v = NIL; - while (iscons(*pv)) { - v = eval(car_(*pv), penv); - *pv = cdr_(*pv); - } - break; - - // ordinary functions - case F_SET: - argcount("set", nargs, 2); - e = Stack[SP-2]; - v = *penv; - while (iscons(v)) { - bind = car_(v); - if (iscons(bind) && car_(bind) == e) { - cdr_(bind) = (v=Stack[SP-1]); - SP=saveSP; return v; - } - v = cdr_(v); - } - tosymbol(e, "set")->binding = (v=Stack[SP-1]); - break; - case F_BOUNDP: - argcount("boundp", nargs, 1); - if (tosymbol(Stack[SP-1], "boundp")->binding == UNBOUND) - v = NIL; - else - v = T; - break; - case F_EQ: - argcount("eq", nargs, 2); - v = ((Stack[SP-2] == Stack[SP-1]) ? T : NIL); - break; - case F_CONS: - argcount("cons", nargs, 2); - v = mk_cons(); - car_(v) = Stack[SP-2]; - cdr_(v) = Stack[SP-1]; - break; - case F_CAR: - argcount("car", nargs, 1); - v = car(Stack[SP-1]); - break; - case F_CDR: - argcount("cdr", nargs, 1); - v = cdr(Stack[SP-1]); - break; - case F_RPLACA: - argcount("rplaca", nargs, 2); - car(v=Stack[SP-2]) = Stack[SP-1]; - break; - case F_RPLACD: - argcount("rplacd", nargs, 2); - cdr(v=Stack[SP-2]) = Stack[SP-1]; - break; - case F_ATOM: - argcount("atom", nargs, 1); - v = ((!iscons(Stack[SP-1])) ? T : NIL); - break; - case F_CONSP: - argcount("consp", nargs, 1); - v = (iscons(Stack[SP-1]) ? T : NIL); - break; - case F_SYMBOLP: - argcount("symbolp", nargs, 1); - v = ((issymbol(Stack[SP-1])) ? T : NIL); - break; - case F_NUMBERP: - argcount("numberp", nargs, 1); - v = ((isnumber(Stack[SP-1])) ? T : NIL); - break; - case F_ADD: - s = 0; - for (i=saveSP+1; i < (int)SP; i++) { - n = tonumber(Stack[i], "+"); - s += n; - } - v = number(s); - break; - case F_SUB: - if (nargs < 1) - lerror("-: error: too few arguments\n"); - i = saveSP+1; - s = (nargs==1) ? 0 : tonumber(Stack[i++], "-"); - for (; i < (int)SP; i++) { - n = tonumber(Stack[i], "-"); - s -= n; - } - v = number(s); - break; - case F_MUL: - s = 1; - for (i=saveSP+1; i < (int)SP; i++) { - n = tonumber(Stack[i], "*"); - s *= n; - } - v = number(s); - break; - case F_DIV: - if (nargs < 1) - lerror("/: error: too few arguments\n"); - i = saveSP+1; - s = (nargs==1) ? 1 : tonumber(Stack[i++], "/"); - for (; i < (int)SP; i++) { - n = tonumber(Stack[i], "/"); - if (n == 0) - lerror("/: error: division by zero\n"); - s /= n; - } - v = number(s); - break; - case F_LT: - argcount("<", nargs, 2); - if (tonumber(Stack[SP-2],"<") < tonumber(Stack[SP-1],"<")) - v = T; - else - v = NIL; - break; - case F_NOT: - argcount("not", nargs, 1); - v = ((Stack[SP-1] == NIL) ? T : NIL); - break; - case F_EVAL: - argcount("eval", nargs, 1); - v = eval(Stack[SP-1], &NIL); - break; - case F_PRINT: - for (i=saveSP+1; i < (int)SP; i++) - print(stdout, v=Stack[i], 0); - fprintf(stdout, "\n"); - break; - case F_PRINC: - for (i=saveSP+1; i < (int)SP; i++) - print(stdout, v=Stack[i], 1); - break; - case F_READ: - argcount("read", nargs, 0); - v = read_sexpr(stdin); - break; - case F_LOAD: - argcount("load", nargs, 1); - v = load_file(tosymbol(Stack[SP-1], "load")->name); - break; - case F_EXIT: - exit(0); - break; - case F_ERROR: - for (i=saveSP+1; i < (int)SP; i++) - print(stderr, Stack[i], 1); - lerror("\n"); - break; - case F_PROG1: - // return first arg - if (nargs < 1) - lerror("prog1: error: too few arguments\n"); - v = Stack[saveSP+1]; - break; - case F_APPLY: - // unpack a list onto the stack - argcount("apply", nargs, 2); - v = Stack[saveSP] = Stack[SP-1]; // second arg is new arglist - f = Stack[SP-2]; // first arg is new function - POPN(2); // pop apply's args - if (isbuiltin(f)) { - if (isspecial(f)) - lerror("apply: error: cannot apply special operator " - "%s\n", builtin_names[intval(f)]); - while (iscons(v)) { - PUSH(car_(v)); - v = cdr_(v); - } - goto apply_builtin; - } - noeval = 1; - goto apply_lambda; - } - SP = saveSP; - return v; - } - else { - v = Stack[saveSP] = cdr_(Stack[saveSP]); - } - apply_lambda: - if (iscons(f)) { - headsym = car_(f); - if (headsym == LABEL) { - // (label name (lambda ...)) behaves the same as the lambda - // alone, except with name bound to the whole label expression - labl = f; - f = car(cdr(cdr_(labl))); - headsym = car(f); - } - // apply lambda or macro expression - PUSH(cdr(cdr(cdr_(f)))); - lenv = &Stack[SP-1]; - PUSH(car_(cdr_(f))); - argsyms = &Stack[SP-1]; - PUSH(car_(cdr_(cdr_(f)))); - body = &Stack[SP-1]; - if (labl) { - // add label binding to environment - PUSH(labl); - PUSH(car_(cdr_(labl))); - *lenv = cons_(cons(&Stack[SP-1], &Stack[SP-2]), lenv); - POPN(3); - v = Stack[saveSP]; // refetch arglist - } - if (headsym == MACRO) - noeval = 1; - else if (headsym != LAMBDA) - lerror("apply: error: head must be lambda, macro, or label\n"); - // build a calling environment for the lambda - // the environment is the argument binds on top of the captured - // environment - while (iscons(v)) { - // bind args - if (!iscons(*argsyms)) { - if (*argsyms == NIL) - lerror("apply: error: too many arguments\n"); - break; - } - asym = car_(*argsyms); - if (!issymbol(asym)) - lerror("apply: error: formal argument not a symbol\n"); - v = car_(v); - if (!noeval) v = eval(v, penv); - PUSH(v); - *lenv = cons_(cons(&asym, &Stack[SP-1]), lenv); - POPN(2); - *argsyms = cdr_(*argsyms); - v = Stack[saveSP] = cdr_(Stack[saveSP]); - } - if (*argsyms != NIL) { - if (issymbol(*argsyms)) { - if (noeval) { - *lenv = cons_(cons(argsyms, &Stack[saveSP]), lenv); - } - else { - PUSH(NIL); - PUSH(NIL); - rest = &Stack[SP-1]; - // build list of rest arguments - // we have to build it forwards, which is tricky - while (iscons(v)) { - v = eval(car_(v), penv); - PUSH(v); - v = cons_(&Stack[SP-1], &NIL); - POP(); - if (iscons(*rest)) - cdr_(*rest) = v; - else - Stack[SP-2] = v; - *rest = v; - v = Stack[saveSP] = cdr_(Stack[saveSP]); - } - *lenv = cons_(cons(argsyms, &Stack[SP-2]), lenv); - } - } - else if (iscons(*argsyms)) { - lerror("apply: error: too few arguments\n"); - } - } - SP = saveSP; // free temporary stack space - PUSH(*lenv); // preserve environment on stack - lenv = &Stack[SP-1]; - v = eval(*body, lenv); - POP(); - // macro: evaluate expansion in the calling environment - if (headsym == MACRO) - return eval(v, penv); - return v; - } - type_error("apply", "function", f); - return NIL; -} diff --git a/tiny/evalt b/tiny/evalt deleted file mode 100644 index 776ddaa..0000000 --- a/tiny/evalt +++ /dev/null @@ -1,443 +0,0 @@ -value_t eval_sexpr(value_t e, value_t *penv) -{ - value_t f, v, bind, headsym, asym, labl=0, *pv, *argsyms, *body, *lenv; - value_t *rest; - cons_t *c; - symbol_t *sym; - u_int32_t saveSP; - int i, nargs, noeval=0; - number_t s, n; - - eval_top: - if (issymbol(e)) { - sym = (symbol_t*)ptr(e); - if (sym->constant != UNBOUND) return sym->constant; - v = *penv; - while (iscons(v)) { - bind = car_(v); - if (iscons(bind) && car_(bind) == e) - return cdr_(bind); - v = cdr_(v); - } - if ((v = sym->binding) == UNBOUND) - lerror("eval: error: variable %s has no value\n", sym->name); - return v; - } - if ((unsigned)(char*)&nargs < (unsigned)stack_bottom || SP>=(N_STACK-100)) - lerror("eval: error: stack overflow\n"); - saveSP = SP; - PUSH(e); - PUSH(*penv); - f = eval(car_(e), penv); - *penv = Stack[saveSP+1]; - if (isbuiltin(f)) { - // handle builtin function - if (!isspecial(f)) { - // evaluate argument list, placing arguments on stack - v = Stack[saveSP] = cdr_(Stack[saveSP]); - while (iscons(v)) { - v = eval(car_(v), penv); - *penv = Stack[saveSP+1]; - PUSH(v); - v = Stack[saveSP] = cdr_(Stack[saveSP]); - } - } - apply_builtin: - nargs = SP - saveSP - 2; - switch (intval(f)) { - // special forms - case F_QUOTE: - v = cdr_(Stack[saveSP]); - if (!iscons(v)) - lerror("quote: error: expected argument\n"); - v = car_(v); - break; - case F_MACRO: - case F_LAMBDA: - v = Stack[saveSP]; - if (*penv != NIL) { - // build a closure (lambda args body . env) - v = cdr_(v); - PUSH(car(v)); - argsyms = &Stack[SP-1]; - PUSH(car(cdr_(v))); - body = &Stack[SP-1]; - v = cons_(intval(f)==F_LAMBDA ? &LAMBDA : &MACRO, - cons(argsyms, cons(body, penv))); - } - break; - case F_LABEL: - v = Stack[saveSP]; - if (*penv != NIL) { - v = cdr_(v); - PUSH(car(v)); // name - pv = &Stack[SP-1]; - PUSH(car(cdr_(v))); // function - body = &Stack[SP-1]; - *body = eval(*body, penv); // evaluate lambda - v = cons_(&LABEL, cons(pv, cons(body, &NIL))); - } - break; - case F_IF: - v = car(cdr_(Stack[saveSP])); - if (eval(v, penv) != NIL) - v = car(cdr_(cdr_(Stack[saveSP]))); - else - v = car(cdr(cdr_(cdr_(Stack[saveSP])))); - tail_eval(v, Stack[saveSP+1]); - break; - case F_COND: - Stack[saveSP] = cdr_(Stack[saveSP]); - pv = &Stack[saveSP]; v = NIL; - while (iscons(*pv)) { - c = tocons(car_(*pv), "cond"); - v = eval(c->car, penv); - *penv = Stack[saveSP+1]; - if (v != NIL) { - *pv = cdr_(car_(*pv)); - // evaluate body forms - if (iscons(*pv)) { - while (iscons(cdr_(*pv))) { - v = eval(car_(*pv), penv); - *penv = Stack[saveSP+1]; - *pv = cdr_(*pv); - } - tail_eval(car_(*pv), *penv); - } - break; - } - *pv = cdr_(*pv); - } - break; - case F_AND: - Stack[saveSP] = cdr_(Stack[saveSP]); - pv = &Stack[saveSP]; v = T; - if (iscons(*pv)) { - while (iscons(cdr_(*pv))) { - if ((v=eval(car_(*pv), penv)) == NIL) { - SP = saveSP; return NIL; - } - *penv = Stack[saveSP+1]; - *pv = cdr_(*pv); - } - tail_eval(car_(*pv), *penv); - } - break; - case F_OR: - Stack[saveSP] = cdr_(Stack[saveSP]); - pv = &Stack[saveSP]; v = NIL; - if (iscons(*pv)) { - while (iscons(cdr_(*pv))) { - if ((v=eval(car_(*pv), penv)) != NIL) { - SP = saveSP; return v; - } - *penv = Stack[saveSP+1]; - *pv = cdr_(*pv); - } - tail_eval(car_(*pv), *penv); - } - break; - case F_WHILE: - PUSH(car(cdr(cdr_(Stack[saveSP])))); - body = &Stack[SP-1]; - Stack[saveSP] = car_(cdr_(Stack[saveSP])); - value_t *cond = &Stack[saveSP]; - PUSH(NIL); pv = &Stack[SP-1]; - while (eval(*cond, penv) != NIL) { - *penv = Stack[saveSP+1]; - *pv = eval(*body, penv); - *penv = Stack[saveSP+1]; - } - v = *pv; - break; - case F_PROGN: - // return last arg - Stack[saveSP] = cdr_(Stack[saveSP]); - pv = &Stack[saveSP]; v = NIL; - if (iscons(*pv)) { - while (iscons(cdr_(*pv))) { - v = eval(car_(*pv), penv); - *penv = Stack[saveSP+1]; - *pv = cdr_(*pv); - } - tail_eval(car_(*pv), *penv); - } - break; - - // ordinary functions - case F_SET: - argcount("set", nargs, 2); - e = Stack[SP-2]; - v = *penv; - while (iscons(v)) { - bind = car_(v); - if (iscons(bind) && car_(bind) == e) { - cdr_(bind) = (v=Stack[SP-1]); - SP=saveSP; return v; - } - v = cdr_(v); - } - tosymbol(e, "set")->binding = (v=Stack[SP-1]); - break; - case F_BOUNDP: - argcount("boundp", nargs, 1); - if (tosymbol(Stack[SP-1], "boundp")->binding == UNBOUND) - v = NIL; - else - v = T; - break; - case F_EQ: - argcount("eq", nargs, 2); - v = ((Stack[SP-2] == Stack[SP-1]) ? T : NIL); - break; - case F_CONS: - argcount("cons", nargs, 2); - v = mk_cons(); - car_(v) = Stack[SP-2]; - cdr_(v) = Stack[SP-1]; - break; - case F_CAR: - argcount("car", nargs, 1); - v = car(Stack[SP-1]); - break; - case F_CDR: - argcount("cdr", nargs, 1); - v = cdr(Stack[SP-1]); - break; - case F_RPLACA: - argcount("rplaca", nargs, 2); - car(v=Stack[SP-2]) = Stack[SP-1]; - break; - case F_RPLACD: - argcount("rplacd", nargs, 2); - cdr(v=Stack[SP-2]) = Stack[SP-1]; - break; - case F_ATOM: - argcount("atom", nargs, 1); - v = ((!iscons(Stack[SP-1])) ? T : NIL); - break; - case F_CONSP: - argcount("consp", nargs, 1); - v = (iscons(Stack[SP-1]) ? T : NIL); - break; - case F_SYMBOLP: - argcount("symbolp", nargs, 1); - v = ((issymbol(Stack[SP-1])) ? T : NIL); - break; - case F_NUMBERP: - argcount("numberp", nargs, 1); - v = ((isnumber(Stack[SP-1])) ? T : NIL); - break; - case F_ADD: - s = 0; - for (i=saveSP+2; i < (int)SP; i++) { - n = tonumber(Stack[i], "+"); - s += n; - } - v = number(s); - break; - case F_SUB: - if (nargs < 1) - lerror("-: error: too few arguments\n"); - i = saveSP+2; - s = (nargs==1) ? 0 : tonumber(Stack[i++], "-"); - for (; i < (int)SP; i++) { - n = tonumber(Stack[i], "-"); - s -= n; - } - v = number(s); - break; - case F_MUL: - s = 1; - for (i=saveSP+2; i < (int)SP; i++) { - n = tonumber(Stack[i], "*"); - s *= n; - } - v = number(s); - break; - case F_DIV: - if (nargs < 1) - lerror("/: error: too few arguments\n"); - i = saveSP+2; - s = (nargs==1) ? 1 : tonumber(Stack[i++], "/"); - for (; i < (int)SP; i++) { - n = tonumber(Stack[i], "/"); - if (n == 0) - lerror("/: error: division by zero\n"); - s /= n; - } - v = number(s); - break; - case F_LT: - argcount("<", nargs, 2); - if (tonumber(Stack[SP-2],"<") < tonumber(Stack[SP-1],"<")) - v = T; - else - v = NIL; - break; - case F_NOT: - argcount("not", nargs, 1); - v = ((Stack[SP-1] == NIL) ? T : NIL); - break; - case F_EVAL: - argcount("eval", nargs, 1); - v = Stack[SP-1]; - tail_eval(v, NIL); - break; - case F_PRINT: - for (i=saveSP+2; i < (int)SP; i++) - print(stdout, v=Stack[i], 0); - fprintf(stdout, "\n"); - break; - case F_PRINC: - for (i=saveSP+2; i < (int)SP; i++) - print(stdout, v=Stack[i], 1); - break; - case F_READ: - argcount("read", nargs, 0); - v = read_sexpr(stdin); - break; - case F_LOAD: - argcount("load", nargs, 1); - v = load_file(tosymbol(Stack[SP-1], "load")->name); - break; - case F_EXIT: - exit(0); - break; - case F_ERROR: - for (i=saveSP+2; i < (int)SP; i++) - print(stderr, Stack[i], 1); - lerror("\n"); - break; - case F_PROG1: - // return first arg - if (nargs < 1) - lerror("prog1: error: too few arguments\n"); - v = Stack[saveSP+2]; - break; - case F_APPLY: - argcount("apply", nargs, 2); - v = Stack[saveSP] = Stack[SP-1]; // second arg is new arglist - f = Stack[SP-2]; // first arg is new function - POPN(2); // pop apply's args - if (isbuiltin(f)) { - if (isspecial(f)) - lerror("apply: error: cannot apply special operator " - "%s\n", builtin_names[intval(f)]); - // unpack arglist onto the stack - while (iscons(v)) { - PUSH(car_(v)); - v = cdr_(v); - } - goto apply_builtin; - } - noeval = 1; - goto apply_lambda; - } - SP = saveSP; - return v; - } - else { - v = Stack[saveSP] = cdr_(Stack[saveSP]); - } - apply_lambda: - if (iscons(f)) { - headsym = car_(f); - if (headsym == LABEL) { - // (label name (lambda ...)) behaves the same as the lambda - // alone, except with name bound to the whole label expression - labl = f; - f = car(cdr(cdr_(labl))); - headsym = car(f); - } - // apply lambda or macro expression - PUSH(cdr(cdr(cdr_(f)))); - lenv = &Stack[SP-1]; - PUSH(car_(cdr_(f))); - argsyms = &Stack[SP-1]; - PUSH(car_(cdr_(cdr_(f)))); - body = &Stack[SP-1]; - if (labl) { - // add label binding to environment - PUSH(labl); - PUSH(car_(cdr_(labl))); - *lenv = cons_(cons(&Stack[SP-1], &Stack[SP-2]), lenv); - POPN(3); - v = Stack[saveSP]; // refetch arglist - } - if (headsym == MACRO) - noeval = 1; - else if (headsym != LAMBDA) - lerror("apply: error: head must be lambda, macro, or label\n"); - // build a calling environment for the lambda - // the environment is the argument binds on top of the captured - // environment - while (iscons(v)) { - // bind args - if (!iscons(*argsyms)) { - if (*argsyms == NIL) - lerror("apply: error: too many arguments\n"); - break; - } - asym = car_(*argsyms); - if (!issymbol(asym)) - lerror("apply: error: formal argument not a symbol\n"); - v = car_(v); - if (!noeval) { - v = eval(v, penv); - *penv = Stack[saveSP+1]; - } - PUSH(v); - *lenv = cons_(cons(&asym, &Stack[SP-1]), lenv); - POPN(2); - *argsyms = cdr_(*argsyms); - v = Stack[saveSP] = cdr_(Stack[saveSP]); - } - if (*argsyms != NIL) { - if (issymbol(*argsyms)) { - if (noeval) { - *lenv = cons_(cons(argsyms, &Stack[saveSP]), lenv); - } - else { - PUSH(NIL); - PUSH(NIL); - rest = &Stack[SP-1]; - // build list of rest arguments - // we have to build it forwards, which is tricky - while (iscons(v)) { - v = eval(car_(v), penv); - *penv = Stack[saveSP+1]; - PUSH(v); - v = cons_(&Stack[SP-1], &NIL); - POP(); - if (iscons(*rest)) - cdr_(*rest) = v; - else - Stack[SP-2] = v; - *rest = v; - v = Stack[saveSP] = cdr_(Stack[saveSP]); - } - *lenv = cons_(cons(argsyms, &Stack[SP-2]), lenv); - } - } - else if (iscons(*argsyms)) { - lerror("apply: error: too few arguments\n"); - } - } - noeval = 0; - // macro: evaluate expansion in the calling environment - if (headsym == MACRO) { - SP = saveSP; - PUSH(*lenv); - lenv = &Stack[SP-1]; - v = eval(*body, lenv); - tail_eval(v, *penv); - } - else { - tail_eval(*body, *lenv); - } - // not reached - } - type_error("apply", "function", f); - return NIL; -} diff --git a/tiny/flutils.c b/tiny/flutils.c deleted file mode 100644 index fffba49..0000000 --- a/tiny/flutils.c +++ /dev/null @@ -1,117 +0,0 @@ -u_int32_t *bitvector_resize(u_int32_t *b, size_t n) -{ - u_int32_t *p; - size_t sz = ((n + 31) >> 5) * 4; - p = realloc(b, sz); - if (p == NULL) - return NULL; - memset(p, 0, sz); - return p; -} - -u_int32_t *mk_bitvector(size_t n) { return bitvector_resize(NULL, n); } - -void bitvector_set(u_int32_t *b, u_int32_t n, u_int32_t c) -{ - if (c) - b[n >> 5] |= (1 << (n & 31)); - else - b[n >> 5] &= ~(1 << (n & 31)); -} - -u_int32_t bitvector_get(u_int32_t *b, u_int32_t n) -{ - return b[n >> 5] & (1 << (n & 31)); -} - -typedef struct { - size_t n, maxsize; - unsigned long *items; -} ltable_t; - -void ltable_init(ltable_t *t, size_t n) -{ - t->n = 0; - t->maxsize = n; - t->items = (unsigned long *)malloc(n * sizeof(unsigned long)); -} - -void ltable_clear(ltable_t *t) { t->n = 0; } - -void ltable_insert(ltable_t *t, unsigned long item) -{ - unsigned long *p; - - if (t->n == t->maxsize) { - p = realloc(t->items, (t->maxsize * 2) * sizeof(unsigned long)); - if (p == NULL) - return; - t->items = p; - t->maxsize *= 2; - } - t->items[t->n++] = item; -} - -#define NOTFOUND ((int)-1) - -int ltable_lookup(ltable_t *t, unsigned long item) -{ - int i; - for (i = 0; i < (int)t->n; i++) - if (t->items[i] == item) - return i; - return NOTFOUND; -} - -void ltable_adjoin(ltable_t *t, unsigned long item) -{ - if (ltable_lookup(t, item) == NOTFOUND) - ltable_insert(t, item); -} - -static const u_int32_t offsetsFromUTF8[6] = { 0x00000000UL, 0x00003080UL, - 0x000E2080UL, 0x03C82080UL, - 0xFA082080UL, 0x82082080UL }; - -static const char trailingBytesForUTF8[256] = { - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, - 1, 1, 1, 1, 1, 1, 1, 1, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, - 3, 3, 3, 3, 3, 3, 3, 3, 4, 4, 4, 4, 5, 5, 5, 5 -}; - -int u8_seqlen(const char c) -{ - return trailingBytesForUTF8[(unsigned int)(unsigned char)c] + 1; -} - -#define UEOF ((u_int32_t)EOF) - -u_int32_t u8_fgetc(FILE *f) -{ - int amt = 0, sz, c; - u_int32_t ch = 0; - - c = fgetc(f); - if (c == EOF) - return UEOF; - ch = (u_int32_t)c; - amt = sz = u8_seqlen(ch); - while (--amt) { - ch <<= 6; - c = fgetc(f); - if (c == EOF) - return UEOF; - ch += (u_int32_t)c; - } - ch -= offsetsFromUTF8[sz - 1]; - - return ch; -} diff --git a/tiny/lisp-nontail.c b/tiny/lisp-nontail.c deleted file mode 100644 index bae1979..0000000 --- a/tiny/lisp-nontail.c +++ /dev/null @@ -1,1032 +0,0 @@ -/* - femtoLisp - - a minimal interpreter for a minimal lisp dialect - - this lisp dialect uses lexical scope and self-evaluating lambda. - it supports 30-bit integers, symbols, conses, and full macros. - it is case-sensitive. - it features a simple compacting copying garbage collector. - it uses a Scheme-style evaluation rule where any expression may appear in - head position as long as it evaluates to a function. - it uses Scheme-style varargs (dotted formal argument lists) - lambdas can have only 1 body expression; use (progn ...) for multiple - expressions. this is due to the closure representation - (lambda args body . env) - - by Jeff Bezanson - Public Domain -*/ - -#include -#include -#include -#include -#include -#include -#include - -typedef u_int32_t value_t; -typedef int32_t number_t; - -typedef struct { - value_t car; - value_t cdr; -} cons_t; - -typedef struct _symbol_t { - value_t binding; // global value binding - value_t constant; // constant binding (used only for builtins) - struct _symbol_t *left; - struct _symbol_t *right; - char name[1]; -} symbol_t; - -#define TAG_NUM 0x0 -#define TAG_BUILTIN 0x1 -#define TAG_SYM 0x2 -#define TAG_CONS 0x3 -#define UNBOUND ((value_t)TAG_SYM) // an invalid symbol pointer -#define tag(x) ((x)&0x3) -#define ptr(x) ((void *)((x) & (~(value_t)0x3))) -#define tagptr(p, t) (((value_t)(p)) | (t)) -#define number(x) ((value_t)((x) << 2)) -#define numval(x) (((number_t)(x)) >> 2) -#define intval(x) (((int)(x)) >> 2) -#define builtin(n) tagptr((((int)n) << 2), TAG_BUILTIN) -#define iscons(x) (tag(x) == TAG_CONS) -#define issymbol(x) (tag(x) == TAG_SYM) -#define isnumber(x) (tag(x) == TAG_NUM) -#define isbuiltin(x) (tag(x) == TAG_BUILTIN) -// functions ending in _ are unsafe, faster versions -#define car_(v) (((cons_t *)ptr(v))->car) -#define cdr_(v) (((cons_t *)ptr(v))->cdr) -#define car(v) (tocons((v), "car")->car) -#define cdr(v) (tocons((v), "cdr")->cdr) -#define set(s, v) (((symbol_t *)ptr(s))->binding = (v)) -#define setc(s, v) (((symbol_t *)ptr(s))->constant = (v)) - -enum { - // special forms - F_QUOTE = 0, - F_COND, - F_IF, - F_AND, - F_OR, - F_WHILE, - F_LAMBDA, - F_MACRO, - F_LABEL, - F_PROGN, - // functions - F_EQ, - F_ATOM, - F_CONS, - F_CAR, - F_CDR, - F_READ, - F_EVAL, - F_PRINT, - F_SET, - F_NOT, - F_LOAD, - F_SYMBOLP, - F_NUMBERP, - F_ADD, - F_SUB, - F_MUL, - F_DIV, - F_LT, - F_PROG1, - F_APPLY, - F_RPLACA, - F_RPLACD, - F_BOUNDP, - N_BUILTINS -}; -#define isspecial(v) (intval(v) <= (int)F_PROGN) - -static char *builtin_names[] = { - "quote", "cond", "if", "and", "or", "while", "lambda", - "macro", "label", "progn", "eq", "atom", "cons", "car", - "cdr", "read", "eval", "print", "set", "not", "load", - "symbolp", "numberp", "+", "-", "*", "/", "<", - "prog1", "apply", "rplaca", "rplacd", "boundp" -}; - -static char *stack_bottom; -#define PROCESS_STACK_SIZE (2 * 1024 * 1024) -#define N_STACK 49152 -static value_t Stack[N_STACK]; -static u_int32_t SP = 0; -#define PUSH(v) (Stack[SP++] = (v)) -#define POP() (Stack[--SP]) -#define POPN(n) (SP -= (n)) - -value_t NIL, T, LAMBDA, MACRO, LABEL, QUOTE; - -value_t read_sexpr(FILE *f); -void print(FILE *f, value_t v); -value_t eval_sexpr(value_t e, value_t *penv); -value_t load_file(char *fname); - -// error utilities -// ------------------------------------------------------------ - -jmp_buf toplevel; - -void lerror(char *format, ...) -{ - va_list args; - va_start(args, format); - vfprintf(stderr, format, args); - va_end(args); - longjmp(toplevel, 1); -} - -void type_error(char *fname, char *expected, value_t got) -{ - fprintf(stderr, "%s: error: expected %s, got ", fname, expected); - print(stderr, got); - lerror("\n"); -} - -// safe cast operators -// -------------------------------------------------------- - -#define SAFECAST_OP(type, ctype, cnvt) \ - ctype to##type(value_t v, char *fname) \ - { \ - if (is##type(v)) \ - return (ctype)cnvt(v); \ - type_error(fname, #type, v); \ - return (ctype)0; \ - } -SAFECAST_OP(cons, cons_t *, ptr) -SAFECAST_OP(symbol, symbol_t *, ptr) -SAFECAST_OP(number, number_t, numval) - -// symbol table -// --------------------------------------------------------------- - -static symbol_t *symtab = NULL; - -static symbol_t *mk_symbol(char *str) -{ - symbol_t *sym; - - sym = (symbol_t *)malloc(sizeof(symbol_t) + strlen(str)); - sym->left = sym->right = NULL; - sym->constant = sym->binding = UNBOUND; - strcpy(&sym->name[0], str); - return sym; -} - -static symbol_t **symtab_lookup(symbol_t **ptree, char *str) -{ - int x; - - while (*ptree != NULL) { - x = strcmp(str, (*ptree)->name); - if (x == 0) - return ptree; - if (x < 0) - ptree = &(*ptree)->left; - else - ptree = &(*ptree)->right; - } - return ptree; -} - -value_t symbol(char *str) -{ - symbol_t **pnode; - - pnode = symtab_lookup(&symtab, str); - if (*pnode == NULL) - *pnode = mk_symbol(str); - return tagptr(*pnode, TAG_SYM); -} - -// initialization -// ------------------------------------------------------------- - -static unsigned char *fromspace; -static unsigned char *tospace; -static unsigned char *curheap; -static unsigned char *lim; -static u_int32_t heapsize = 64 * 1024; // bytes - -void lisp_init(void) -{ - int i; - - fromspace = malloc(heapsize); - tospace = malloc(heapsize); - curheap = fromspace; - lim = curheap + heapsize - sizeof(cons_t); - - NIL = symbol("nil"); - setc(NIL, NIL); - T = symbol("t"); - setc(T, T); - LAMBDA = symbol("lambda"); - MACRO = symbol("macro"); - LABEL = symbol("label"); - QUOTE = symbol("quote"); - for (i = 0; i < (int)N_BUILTINS; i++) - setc(symbol(builtin_names[i]), builtin(i)); - setc(symbol("princ"), builtin(F_PRINT)); -} - -// conses -// --------------------------------------------------------------------- - -void gc(void); - -static value_t mk_cons(void) -{ - cons_t *c; - - if (curheap > lim) - gc(); - c = (cons_t *)curheap; - curheap += sizeof(cons_t); - return tagptr(c, TAG_CONS); -} - -static value_t cons_(value_t *pcar, value_t *pcdr) -{ - value_t c = mk_cons(); - car_(c) = *pcar; - cdr_(c) = *pcdr; - return c; -} - -value_t *cons(value_t *pcar, value_t *pcdr) -{ - value_t c = mk_cons(); - car_(c) = *pcar; - cdr_(c) = *pcdr; - PUSH(c); - return &Stack[SP - 1]; -} - -// collector -// ------------------------------------------------------------------ - -static value_t relocate(value_t v) -{ - value_t a, d, nc; - - if (!iscons(v)) - return v; - if (car_(v) == UNBOUND) - return cdr_(v); - nc = mk_cons(); - a = car_(v); - d = cdr_(v); - car_(v) = UNBOUND; - cdr_(v) = nc; - car_(nc) = relocate(a); - cdr_(nc) = relocate(d); - return nc; -} - -static void trace_globals(symbol_t *root) -{ - while (root != NULL) { - root->binding = relocate(root->binding); - trace_globals(root->left); - root = root->right; - } -} - -void gc(void) -{ - static int grew = 0; - unsigned char *temp; - u_int32_t i; - - curheap = tospace; - lim = curheap + heapsize - sizeof(cons_t); - - for (i = 0; i < SP; i++) - Stack[i] = relocate(Stack[i]); - trace_globals(symtab); -#ifdef VERBOSEGC - printf("gc found %d/%d live conses\n", (curheap - tospace) / 8, - heapsize / 8); -#endif - temp = tospace; - tospace = fromspace; - fromspace = temp; - - // if we're using > 80% of the space, resize tospace so we have - // more space to fill next time. if we grew tospace last time, - // grow the other half of the heap this time to catch up. - if (grew || ((lim - curheap) < (int)(heapsize / 5))) { - temp = realloc(tospace, grew ? heapsize : heapsize * 2); - if (temp == NULL) - lerror("out of memory\n"); - tospace = temp; - if (!grew) - heapsize *= 2; - grew = !grew; - } - if (curheap > lim) // all data was live - gc(); -} - -// read -// ----------------------------------------------------------------------- - -enum { TOK_NONE, TOK_OPEN, TOK_CLOSE, TOK_DOT, TOK_QUOTE, TOK_SYM, TOK_NUM }; - -static int symchar(char c) -{ - static char *special = "()';\\|"; - return (!isspace(c) && !strchr(special, c)); -} - -static u_int32_t toktype = TOK_NONE; -static value_t tokval; -static char buf[256]; - -static char nextchar(FILE *f) -{ - char c; - int ch; - - do { - ch = fgetc(f); - if (ch == EOF) - return 0; - c = (char)ch; - if (c == ';') { - // single-line comment - do { - ch = fgetc(f); - if (ch == EOF) - return 0; - } while ((char)ch != '\n'); - c = (char)ch; - } - } while (isspace(c)); - return c; -} - -static void take(void) { toktype = TOK_NONE; } - -static void accumchar(char c, int *pi) -{ - buf[(*pi)++] = c; - if (*pi >= (int)(sizeof(buf) - 1)) - lerror("read: error: token too long\n"); -} - -static int read_token(FILE *f, char c) -{ - int i = 0, ch, escaped = 0; - - ungetc(c, f); - while (1) { - ch = fgetc(f); - if (ch == EOF) - goto terminate; - c = (char)ch; - if (c == '|') { - escaped = !escaped; - } else if (c == '\\') { - ch = fgetc(f); - if (ch == EOF) - goto terminate; - accumchar((char)ch, &i); - } else if (!escaped && !symchar(c)) { - break; - } else { - accumchar(c, &i); - } - } - ungetc(c, f); -terminate: - buf[i++] = '\0'; - return i; -} - -static u_int32_t peek(FILE *f) -{ - char c, *end; - number_t x; - - if (toktype != TOK_NONE) - return toktype; - c = nextchar(f); - if (feof(f)) - return TOK_NONE; - if (c == '(') { - toktype = TOK_OPEN; - } else if (c == ')') { - toktype = TOK_CLOSE; - } else if (c == '\'') { - toktype = TOK_QUOTE; - } else if (isdigit(c) || c == '-') { - read_token(f, c); - if (buf[0] == '-' && !isdigit(buf[1])) { - toktype = TOK_SYM; - tokval = symbol(buf); - } else { - x = strtol(buf, &end, 10); - if (*end != '\0') - lerror("read: error: invalid integer constant\n"); - toktype = TOK_NUM; - tokval = number(x); - } - } else { - read_token(f, c); - if (!strcmp(buf, ".")) { - toktype = TOK_DOT; - } else { - toktype = TOK_SYM; - tokval = symbol(buf); - } - } - return toktype; -} - -// build a list of conses. this is complicated by the fact that all conses -// can move whenever a new cons is allocated. we have to refer to every cons -// through a handle to a relocatable pointer (i.e. a pointer on the stack). -static void read_list(FILE *f, value_t *pval) -{ - value_t c, *pc; - u_int32_t t; - - PUSH(NIL); - pc = &Stack[SP - 1]; // to keep track of current cons cell - t = peek(f); - while (t != TOK_CLOSE) { - if (feof(f)) - lerror("read: error: unexpected end of input\n"); - c = mk_cons(); - car_(c) = cdr_(c) = NIL; - if (iscons(*pc)) - cdr_(*pc) = c; - else - *pval = c; - *pc = c; - c = read_sexpr(f); // must be on separate lines due to undefined - car_(*pc) = c; // evaluation order - - t = peek(f); - if (t == TOK_DOT) { - take(); - c = read_sexpr(f); - cdr_(*pc) = c; - t = peek(f); - if (feof(f)) - lerror("read: error: unexpected end of input\n"); - if (t != TOK_CLOSE) - lerror("read: error: expected ')'\n"); - } - } - take(); - POP(); -} - -value_t read_sexpr(FILE *f) -{ - value_t v; - - switch (peek(f)) { - case TOK_CLOSE: - take(); - lerror("read: error: unexpected ')'\n"); - case TOK_DOT: - take(); - lerror("read: error: unexpected '.'\n"); - case TOK_SYM: - case TOK_NUM: - take(); - return tokval; - case TOK_QUOTE: - take(); - v = read_sexpr(f); - PUSH(v); - v = cons_("E, cons(&Stack[SP - 1], &NIL)); - POPN(2); - return v; - case TOK_OPEN: - take(); - PUSH(NIL); - read_list(f, &Stack[SP - 1]); - return POP(); - } - return NIL; -} - -// print -// ---------------------------------------------------------------------- - -void print(FILE *f, value_t v) -{ - value_t cd; - - switch (tag(v)) { - case TAG_NUM: - fprintf(f, "%d", numval(v)); - break; - case TAG_SYM: - fprintf(f, "%s", ((symbol_t *)ptr(v))->name); - break; - case TAG_BUILTIN: - fprintf(f, "#", builtin_names[intval(v)]); - break; - case TAG_CONS: - fprintf(f, "("); - while (1) { - print(f, car_(v)); - cd = cdr_(v); - if (!iscons(cd)) { - if (cd != NIL) { - fprintf(f, " . "); - print(f, cd); - } - fprintf(f, ")"); - break; - } - fprintf(f, " "); - v = cd; - } - break; - } -} - -// eval -// ----------------------------------------------------------------------- - -static inline void argcount(char *fname, int nargs, int c) -{ - if (nargs != c) - lerror("%s: error: too %s arguments\n", fname, - nargs < c ? "few" : "many"); -} - -#define eval(e, env) ((tag(e) < 0x2) ? (e) : eval_sexpr((e), env)) - -value_t eval_sexpr(value_t e, value_t *penv) -{ - value_t f, v, bind, headsym, asym, labl = 0, *pv, *argsyms, *body, *lenv; - value_t *rest; - cons_t *c; - symbol_t *sym; - u_int32_t saveSP; - int i, nargs, noeval = 0; - number_t s, n; - - if (issymbol(e)) { - sym = (symbol_t *)ptr(e); - if (sym->constant != UNBOUND) - return sym->constant; - v = *penv; - while (iscons(v)) { - bind = car_(v); - if (iscons(bind) && car_(bind) == e) - return cdr_(bind); - v = cdr_(v); - } - if ((v = sym->binding) == UNBOUND) - lerror("eval: error: variable %s has no value\n", sym->name); - return v; - } - if ((unsigned)(char *)&nargs < (unsigned)stack_bottom || - SP >= (N_STACK - 100)) - lerror("eval: error: stack overflow\n"); - saveSP = SP; - PUSH(e); - f = eval(car_(e), penv); - if (isbuiltin(f)) { - // handle builtin function - if (!isspecial(f)) { - // evaluate argument list, placing arguments on stack - v = Stack[saveSP] = cdr_(Stack[saveSP]); - while (iscons(v)) { - v = eval(car_(v), penv); - PUSH(v); - v = Stack[saveSP] = cdr_(Stack[saveSP]); - } - } - apply_builtin: - nargs = SP - saveSP - 1; - switch (intval(f)) { - // special forms - case F_QUOTE: - v = cdr_(Stack[saveSP]); - if (!iscons(v)) - lerror("quote: error: expected argument\n"); - v = car_(v); - break; - case F_MACRO: - case F_LAMBDA: - v = Stack[saveSP]; - if (*penv != NIL) { - // build a closure (lambda args body . env) - v = cdr_(v); - PUSH(car(v)); - argsyms = &Stack[SP - 1]; - PUSH(car(cdr_(v))); - body = &Stack[SP - 1]; - v = cons_(intval(f) == F_LAMBDA ? &LAMBDA : &MACRO, - cons(argsyms, cons(body, penv))); - } - break; - case F_LABEL: - v = Stack[saveSP]; - if (*penv != NIL) { - v = cdr_(v); - PUSH(car(v)); // name - pv = &Stack[SP - 1]; - PUSH(car(cdr_(v))); // function - body = &Stack[SP - 1]; - *body = eval(*body, penv); // evaluate lambda - v = cons_(&LABEL, cons(pv, cons(body, &NIL))); - } - break; - case F_IF: - v = car(cdr_(Stack[saveSP])); - if (eval(v, penv) != NIL) - v = car(cdr_(cdr_(Stack[saveSP]))); - else - v = car(cdr(cdr_(cdr_(Stack[saveSP])))); - v = eval(v, penv); - break; - case F_COND: - Stack[saveSP] = cdr_(Stack[saveSP]); - pv = &Stack[saveSP]; - v = NIL; - while (iscons(*pv)) { - c = tocons(car_(*pv), "cond"); - if ((v = eval(c->car, penv)) != NIL) { - *pv = cdr_(car_(*pv)); - // evaluate body forms - while (iscons(*pv)) { - v = eval(car_(*pv), penv); - *pv = cdr_(*pv); - } - break; - } - *pv = cdr_(*pv); - } - break; - case F_AND: - Stack[saveSP] = cdr_(Stack[saveSP]); - pv = &Stack[saveSP]; - v = T; - while (iscons(*pv)) { - if ((v = eval(car_(*pv), penv)) == NIL) - break; - *pv = cdr_(*pv); - } - break; - case F_OR: - Stack[saveSP] = cdr_(Stack[saveSP]); - pv = &Stack[saveSP]; - v = NIL; - while (iscons(*pv)) { - if ((v = eval(car_(*pv), penv)) != NIL) - break; - *pv = cdr_(*pv); - } - break; - case F_WHILE: - PUSH(car(cdr(cdr_(Stack[saveSP])))); - body = &Stack[SP - 1]; - Stack[saveSP] = car_(cdr_(Stack[saveSP])); - value_t *cond = &Stack[saveSP]; - PUSH(NIL); - pv = &Stack[SP - 1]; - while (eval(*cond, penv) != NIL) - *pv = eval(*body, penv); - v = *pv; - break; - case F_PROGN: - // return last arg - Stack[saveSP] = cdr_(Stack[saveSP]); - pv = &Stack[saveSP]; - v = NIL; - while (iscons(*pv)) { - v = eval(car_(*pv), penv); - *pv = cdr_(*pv); - } - break; - - // ordinary functions - case F_SET: - argcount("set", nargs, 2); - e = Stack[SP - 2]; - v = *penv; - while (iscons(v)) { - bind = car_(v); - if (iscons(bind) && car_(bind) == e) { - cdr_(bind) = (v = Stack[SP - 1]); - SP = saveSP; - return v; - } - v = cdr_(v); - } - tosymbol(e, "set")->binding = (v = Stack[SP - 1]); - break; - case F_BOUNDP: - argcount("boundp", nargs, 1); - if (tosymbol(Stack[SP - 1], "boundp")->binding == UNBOUND) - v = NIL; - else - v = T; - break; - case F_EQ: - argcount("eq", nargs, 2); - v = ((Stack[SP - 2] == Stack[SP - 1]) ? T : NIL); - break; - case F_CONS: - argcount("cons", nargs, 2); - v = mk_cons(); - car_(v) = Stack[SP - 2]; - cdr_(v) = Stack[SP - 1]; - break; - case F_CAR: - argcount("car", nargs, 1); - v = car(Stack[SP - 1]); - break; - case F_CDR: - argcount("cdr", nargs, 1); - v = cdr(Stack[SP - 1]); - break; - case F_RPLACA: - argcount("rplaca", nargs, 2); - car(v = Stack[SP - 2]) = Stack[SP - 1]; - break; - case F_RPLACD: - argcount("rplacd", nargs, 2); - cdr(v = Stack[SP - 2]) = Stack[SP - 1]; - break; - case F_ATOM: - argcount("atom", nargs, 1); - v = ((!iscons(Stack[SP - 1])) ? T : NIL); - break; - case F_SYMBOLP: - argcount("symbolp", nargs, 1); - v = ((issymbol(Stack[SP - 1])) ? T : NIL); - break; - case F_NUMBERP: - argcount("numberp", nargs, 1); - v = ((isnumber(Stack[SP - 1])) ? T : NIL); - break; - case F_ADD: - s = 0; - for (i = saveSP + 1; i < (int)SP; i++) { - n = tonumber(Stack[i], "+"); - s += n; - } - v = number(s); - break; - case F_SUB: - if (nargs < 1) - lerror("-: error: too few arguments\n"); - i = saveSP + 1; - s = (nargs == 1) ? 0 : tonumber(Stack[i++], "-"); - for (; i < (int)SP; i++) { - n = tonumber(Stack[i], "-"); - s -= n; - } - v = number(s); - break; - case F_MUL: - s = 1; - for (i = saveSP + 1; i < (int)SP; i++) { - n = tonumber(Stack[i], "*"); - s *= n; - } - v = number(s); - break; - case F_DIV: - if (nargs < 1) - lerror("/: error: too few arguments\n"); - i = saveSP + 1; - s = (nargs == 1) ? 1 : tonumber(Stack[i++], "/"); - for (; i < (int)SP; i++) { - n = tonumber(Stack[i], "/"); - if (n == 0) - lerror("/: error: division by zero\n"); - s /= n; - } - v = number(s); - break; - case F_LT: - argcount("<", nargs, 2); - if (tonumber(Stack[SP - 2], "<") < tonumber(Stack[SP - 1], "<")) - v = T; - else - v = NIL; - break; - case F_NOT: - argcount("not", nargs, 1); - v = ((Stack[SP - 1] == NIL) ? T : NIL); - break; - case F_EVAL: - argcount("eval", nargs, 1); - v = eval(Stack[SP - 1], &NIL); - break; - case F_PRINT: - for (i = saveSP + 1; i < (int)SP; i++) - print(stdout, v = Stack[i]); - break; - case F_READ: - argcount("read", nargs, 0); - v = read_sexpr(stdin); - break; - case F_LOAD: - argcount("load", nargs, 1); - v = load_file(tosymbol(Stack[SP - 1], "load")->name); - break; - case F_PROG1: - // return first arg - if (nargs < 1) - lerror("prog1: error: too few arguments\n"); - v = Stack[saveSP + 1]; - break; - case F_APPLY: - // unpack a list onto the stack - argcount("apply", nargs, 2); - v = Stack[saveSP] = Stack[SP - 1]; // second arg is new arglist - f = Stack[SP - 2]; // first arg is new function - POPN(2); // pop apply's args - if (isbuiltin(f)) { - if (isspecial(f)) - lerror("apply: error: cannot apply special operator " - "%s\n", - builtin_names[intval(f)]); - while (iscons(v)) { - PUSH(car_(v)); - v = cdr_(v); - } - goto apply_builtin; - } - noeval = 1; - goto apply_lambda; - } - SP = saveSP; - return v; - } else { - v = Stack[saveSP] = cdr_(Stack[saveSP]); - } -apply_lambda: - if (iscons(f)) { - headsym = car_(f); - if (headsym == LABEL) { - // (label name (lambda ...)) behaves the same as the lambda - // alone, except with name bound to the whole label expression - labl = f; - f = car(cdr(cdr_(labl))); - headsym = car(f); - } - // apply lambda or macro expression - PUSH(cdr(cdr(cdr_(f)))); - lenv = &Stack[SP - 1]; - PUSH(car_(cdr_(f))); - argsyms = &Stack[SP - 1]; - PUSH(car_(cdr_(cdr_(f)))); - body = &Stack[SP - 1]; - if (labl) { - // add label binding to environment - PUSH(labl); - PUSH(car_(cdr_(labl))); - *lenv = cons_(cons(&Stack[SP - 1], &Stack[SP - 2]), lenv); - POPN(3); - v = Stack[saveSP]; // refetch arglist - } - if (headsym == MACRO) - noeval = 1; - else if (headsym != LAMBDA) - lerror("apply: error: head must be lambda, macro, or label\n"); - // build a calling environment for the lambda - // the environment is the argument binds on top of the captured - // environment - while (iscons(v)) { - // bind args - if (!iscons(*argsyms)) { - if (*argsyms == NIL) - lerror("apply: error: too many arguments\n"); - break; - } - asym = car_(*argsyms); - if (!issymbol(asym)) - lerror("apply: error: formal argument not a symbol\n"); - v = car_(v); - if (!noeval) - v = eval(v, penv); - PUSH(v); - *lenv = cons_(cons(&asym, &Stack[SP - 1]), lenv); - POPN(2); - *argsyms = cdr_(*argsyms); - v = Stack[saveSP] = cdr_(Stack[saveSP]); - } - if (*argsyms != NIL) { - if (issymbol(*argsyms)) { - if (noeval) { - *lenv = cons_(cons(argsyms, &Stack[saveSP]), lenv); - } else { - PUSH(NIL); - PUSH(NIL); - rest = &Stack[SP - 1]; - // build list of rest arguments - // we have to build it forwards, which is tricky - while (iscons(v)) { - v = eval(car_(v), penv); - PUSH(v); - v = cons_(&Stack[SP - 1], &NIL); - POP(); - if (iscons(*rest)) - cdr_(*rest) = v; - else - Stack[SP - 2] = v; - *rest = v; - v = Stack[saveSP] = cdr_(Stack[saveSP]); - } - *lenv = cons_(cons(argsyms, &Stack[SP - 2]), lenv); - } - } else if (iscons(*argsyms)) { - lerror("apply: error: too few arguments\n"); - } - } - SP = saveSP; // free temporary stack space - PUSH(*lenv); // preserve environment on stack - lenv = &Stack[SP - 1]; - v = eval(*body, lenv); - POP(); - // macro: evaluate expansion in the calling environment - if (headsym == MACRO) - return eval(v, penv); - return v; - } - type_error("apply", "function", f); - return NIL; -} - -// repl -// ----------------------------------------------------------------------- - -static char *infile = NULL; - -value_t load_file(char *fname) -{ - value_t e, v = NIL; - char *lastfile = infile; - FILE *f = fopen(fname, "r"); - infile = fname; - if (f == NULL) - lerror("file not found\n"); - while (1) { - e = read_sexpr(f); - if (feof(f)) - break; - v = eval(e, &NIL); - } - infile = lastfile; - fclose(f); - return v; -} - -int main(int argc, char *argv[]) -{ - value_t v; - - stack_bottom = ((char *)&v) - PROCESS_STACK_SIZE; - lisp_init(); - if (setjmp(toplevel)) { - SP = 0; - fprintf(stderr, "\n"); - if (infile) { - fprintf(stderr, "error loading file \"%s\"\n", infile); - infile = NULL; - } - goto repl; - } - load_file("system.lsp"); - if (argc > 1) { - load_file(argv[1]); - return 0; - } - printf("Welcome to femtoLisp " - "----------------------------------------------------------\n"); -repl: - while (1) { - printf("> "); - v = read_sexpr(stdin); - if (feof(stdin)) - break; - print(stdout, v = eval(v, &NIL)); - set(symbol("that"), v); - printf("\n\n"); - } - return 0; -} diff --git a/tiny/lisp.c b/tiny/lisp.c deleted file mode 100644 index 1e70c8c..0000000 --- a/tiny/lisp.c +++ /dev/null @@ -1,1099 +0,0 @@ -/* - femtoLisp - - a minimal interpreter for a minimal lisp dialect - - this lisp dialect uses lexical scope and self-evaluating lambda. - it supports 30-bit integers, symbols, conses, and full macros. - it is case-sensitive. - it features a simple compacting copying garbage collector. - it uses a Scheme-style evaluation rule where any expression may appear in - head position as long as it evaluates to a function. - it uses Scheme-style varargs (dotted formal argument lists) - lambdas can have only 1 body expression; use (progn ...) for multiple - expressions. this is due to the closure representation - (lambda args body . env) - - by Jeff Bezanson - Public Domain -*/ - -#include -#include -#include -#include -#include -#include -#include - -#ifdef __LP64__ -typedef u_int64_t value_t; -typedef int64_t number_t; -#else -typedef u_int32_t value_t; -typedef int32_t number_t; -#endif - -typedef struct { - value_t car; - value_t cdr; -} cons_t; - -typedef struct _symbol_t { - value_t binding; // global value binding - value_t constant; // constant binding (used only for builtins) - struct _symbol_t *left; - struct _symbol_t *right; - char name[1]; -} symbol_t; - -#define TAG_NUM 0x0 -#define TAG_BUILTIN 0x1 -#define TAG_SYM 0x2 -#define TAG_CONS 0x3 -#define UNBOUND ((value_t)TAG_SYM) // an invalid symbol pointer -#define tag(x) ((x)&0x3) -#define ptr(x) ((void *)((x) & (~(value_t)0x3))) -#define tagptr(p, t) (((value_t)(p)) | (t)) -#define number(x) ((value_t)((x) << 2)) -#define numval(x) (((number_t)(x)) >> 2) -#define intval(x) (((int)(x)) >> 2) -#define builtin(n) tagptr((((int)n) << 2), TAG_BUILTIN) -#define iscons(x) (tag(x) == TAG_CONS) -#define issymbol(x) (tag(x) == TAG_SYM) -#define isnumber(x) (tag(x) == TAG_NUM) -#define isbuiltin(x) (tag(x) == TAG_BUILTIN) -// functions ending in _ are unsafe, faster versions -#define car_(v) (((cons_t *)ptr(v))->car) -#define cdr_(v) (((cons_t *)ptr(v))->cdr) -#define car(v) (tocons((v), "car")->car) -#define cdr(v) (tocons((v), "cdr")->cdr) -#define set(s, v) (((symbol_t *)ptr(s))->binding = (v)) -#define setc(s, v) (((symbol_t *)ptr(s))->constant = (v)) - -enum { - // special forms - F_QUOTE = 0, - F_COND, - F_IF, - F_AND, - F_OR, - F_WHILE, - F_LAMBDA, - F_MACRO, - F_LABEL, - F_PROGN, - // functions - F_EQ, - F_ATOM, - F_CONS, - F_CAR, - F_CDR, - F_READ, - F_EVAL, - F_PRINT, - F_SET, - F_NOT, - F_LOAD, - F_SYMBOLP, - F_NUMBERP, - F_ADD, - F_SUB, - F_MUL, - F_DIV, - F_LT, - F_PROG1, - F_APPLY, - F_RPLACA, - F_RPLACD, - F_BOUNDP, - N_BUILTINS -}; -#define isspecial(v) (intval(v) <= (int)F_PROGN) - -static char *builtin_names[] = { - "quote", "cond", "if", "and", "or", "while", "lambda", - "macro", "label", "progn", "eq", "atom", "cons", "car", - "cdr", "read", "eval", "print", "set", "not", "load", - "symbolp", "numberp", "+", "-", "*", "/", "<", - "prog1", "apply", "rplaca", "rplacd", "boundp" -}; - -static char *stack_bottom; -#define PROCESS_STACK_SIZE (2 * 1024 * 1024) -#define N_STACK 49152 -static value_t Stack[N_STACK]; -static u_int32_t SP = 0; -#define PUSH(v) (Stack[SP++] = (v)) -#define POP() (Stack[--SP]) -#define POPN(n) (SP -= (n)) - -value_t NIL, T, LAMBDA, MACRO, LABEL, QUOTE; - -value_t read_sexpr(FILE *f); -void print(FILE *f, value_t v); -value_t eval_sexpr(value_t e, value_t *penv); -value_t load_file(char *fname); - -// error utilities -// ------------------------------------------------------------ - -jmp_buf toplevel; - -void lerror(char *format, ...) -{ - va_list args; - va_start(args, format); - vfprintf(stderr, format, args); - va_end(args); - longjmp(toplevel, 1); -} - -void type_error(char *fname, char *expected, value_t got) -{ - fprintf(stderr, "%s: error: expected %s, got ", fname, expected); - print(stderr, got); - lerror("\n"); -} - -// safe cast operators -// -------------------------------------------------------- - -#define SAFECAST_OP(type, ctype, cnvt) \ - ctype to##type(value_t v, char *fname) \ - { \ - if (is##type(v)) \ - return (ctype)cnvt(v); \ - type_error(fname, #type, v); \ - return (ctype)0; \ - } -SAFECAST_OP(cons, cons_t *, ptr) -SAFECAST_OP(symbol, symbol_t *, ptr) -SAFECAST_OP(number, number_t, numval) - -// symbol table -// --------------------------------------------------------------- - -static symbol_t *symtab = NULL; - -static symbol_t *mk_symbol(char *str) -{ - symbol_t *sym; - - sym = (symbol_t *)malloc(sizeof(symbol_t) + strlen(str)); - sym->left = sym->right = NULL; - sym->constant = sym->binding = UNBOUND; - strcpy(&sym->name[0], str); - return sym; -} - -static symbol_t **symtab_lookup(symbol_t **ptree, char *str) -{ - int x; - - while (*ptree != NULL) { - x = strcmp(str, (*ptree)->name); - if (x == 0) - return ptree; - if (x < 0) - ptree = &(*ptree)->left; - else - ptree = &(*ptree)->right; - } - return ptree; -} - -value_t symbol(char *str) -{ - symbol_t **pnode; - - pnode = symtab_lookup(&symtab, str); - if (*pnode == NULL) - *pnode = mk_symbol(str); - return tagptr(*pnode, TAG_SYM); -} - -// initialization -// ------------------------------------------------------------- - -static unsigned char *fromspace; -static unsigned char *tospace; -static unsigned char *curheap; -static unsigned char *lim; -static u_int32_t heapsize = 64 * 1024; // bytes - -void lisp_init(void) -{ - int i; - - fromspace = malloc(heapsize); - tospace = malloc(heapsize); - curheap = fromspace; - lim = curheap + heapsize - sizeof(cons_t); - - NIL = symbol("nil"); - setc(NIL, NIL); - T = symbol("t"); - setc(T, T); - LAMBDA = symbol("lambda"); - MACRO = symbol("macro"); - LABEL = symbol("label"); - QUOTE = symbol("quote"); - for (i = 0; i < (int)N_BUILTINS; i++) - setc(symbol(builtin_names[i]), builtin(i)); - setc(symbol("princ"), builtin(F_PRINT)); -} - -// conses -// --------------------------------------------------------------------- - -void gc(void); - -static value_t mk_cons(void) -{ - cons_t *c; - - if (curheap > lim) - gc(); - c = (cons_t *)curheap; - curheap += sizeof(cons_t); - return tagptr(c, TAG_CONS); -} - -static value_t cons_(value_t *pcar, value_t *pcdr) -{ - value_t c = mk_cons(); - car_(c) = *pcar; - cdr_(c) = *pcdr; - return c; -} - -value_t *cons(value_t *pcar, value_t *pcdr) -{ - value_t c = mk_cons(); - car_(c) = *pcar; - cdr_(c) = *pcdr; - PUSH(c); - return &Stack[SP - 1]; -} - -// collector -// ------------------------------------------------------------------ - -static value_t relocate(value_t v) -{ - value_t a, d, nc; - - if (!iscons(v)) - return v; - if (car_(v) == UNBOUND) - return cdr_(v); - nc = mk_cons(); - a = car_(v); - d = cdr_(v); - car_(v) = UNBOUND; - cdr_(v) = nc; - car_(nc) = relocate(a); - cdr_(nc) = relocate(d); - return nc; -} - -static void trace_globals(symbol_t *root) -{ - while (root != NULL) { - root->binding = relocate(root->binding); - trace_globals(root->left); - root = root->right; - } -} - -void gc(void) -{ - static int grew = 0; - unsigned char *temp; - u_int32_t i; - - curheap = tospace; - lim = curheap + heapsize - sizeof(cons_t); - - for (i = 0; i < SP; i++) - Stack[i] = relocate(Stack[i]); - trace_globals(symtab); -#ifdef VERBOSEGC - printf("gc found %d/%d live conses\n", (curheap - tospace) / 8, - heapsize / 8); -#endif - temp = tospace; - tospace = fromspace; - fromspace = temp; - - // if we're using > 80% of the space, resize tospace so we have - // more space to fill next time. if we grew tospace last time, - // grow the other half of the heap this time to catch up. - if (grew || ((lim - curheap) < (int)(heapsize / 5))) { - temp = realloc(tospace, grew ? heapsize : heapsize * 2); - if (temp == NULL) - lerror("out of memory\n"); - tospace = temp; - if (!grew) - heapsize *= 2; - grew = !grew; - } - if (curheap > lim) // all data was live - gc(); -} - -// read -// ----------------------------------------------------------------------- - -enum { TOK_NONE, TOK_OPEN, TOK_CLOSE, TOK_DOT, TOK_QUOTE, TOK_SYM, TOK_NUM }; - -static int symchar(char c) -{ - static char *special = "()';\\|"; - return (!isspace(c) && !strchr(special, c)); -} - -static u_int32_t toktype = TOK_NONE; -static value_t tokval; -static char buf[256]; - -static char nextchar(FILE *f) -{ - char c; - int ch; - - do { - ch = fgetc(f); - if (ch == EOF) - return 0; - c = (char)ch; - if (c == ';') { - // single-line comment - do { - ch = fgetc(f); - if (ch == EOF) - return 0; - } while ((char)ch != '\n'); - c = (char)ch; - } - } while (isspace(c)); - return c; -} - -static void take(void) { toktype = TOK_NONE; } - -static void accumchar(char c, int *pi) -{ - buf[(*pi)++] = c; - if (*pi >= (int)(sizeof(buf) - 1)) - lerror("read: error: token too long\n"); -} - -// return: 1 for dot token, 0 for symbol -static int read_token(FILE *f, char c) -{ - int i = 0, ch, escaped = 0, dot = (c == '.'), totread = 0; - - ungetc(c, f); - while (1) { - ch = fgetc(f); - totread++; - if (ch == EOF) - goto terminate; - c = (char)ch; - if (c == '|') { - escaped = !escaped; - } else if (c == '\\') { - ch = fgetc(f); - if (ch == EOF) - goto terminate; - accumchar((char)ch, &i); - } else if (!escaped && !symchar(c)) { - break; - } else { - accumchar(c, &i); - } - } - ungetc(c, f); -terminate: - buf[i++] = '\0'; - return (dot && (totread == 2)); -} - -static u_int32_t peek(FILE *f) -{ - char c, *end; - number_t x; - - if (toktype != TOK_NONE) - return toktype; - c = nextchar(f); - if (feof(f)) - return TOK_NONE; - if (c == '(') { - toktype = TOK_OPEN; - } else if (c == ')') { - toktype = TOK_CLOSE; - } else if (c == '\'') { - toktype = TOK_QUOTE; - } else if (isdigit(c) || c == '-' || c == '+') { - read_token(f, c); - x = strtol(buf, &end, 0); - if (*end != '\0') { - toktype = TOK_SYM; - tokval = symbol(buf); - } else { - toktype = TOK_NUM; - tokval = number(x); - } - } else { - if (read_token(f, c)) { - toktype = TOK_DOT; - } else { - toktype = TOK_SYM; - tokval = symbol(buf); - } - } - return toktype; -} - -// build a list of conses. this is complicated by the fact that all conses -// can move whenever a new cons is allocated. we have to refer to every cons -// through a handle to a relocatable pointer (i.e. a pointer on the stack). -static void read_list(FILE *f, value_t *pval) -{ - value_t c, *pc; - u_int32_t t; - - PUSH(NIL); - pc = &Stack[SP - 1]; // to keep track of current cons cell - t = peek(f); - while (t != TOK_CLOSE) { - if (feof(f)) - lerror("read: error: unexpected end of input\n"); - c = mk_cons(); - car_(c) = cdr_(c) = NIL; - if (iscons(*pc)) - cdr_(*pc) = c; - else - *pval = c; - *pc = c; - c = read_sexpr(f); // must be on separate lines due to undefined - car_(*pc) = c; // evaluation order - - t = peek(f); - if (t == TOK_DOT) { - take(); - c = read_sexpr(f); - cdr_(*pc) = c; - t = peek(f); - if (feof(f)) - lerror("read: error: unexpected end of input\n"); - if (t != TOK_CLOSE) - lerror("read: error: expected ')'\n"); - } - } - take(); - POP(); -} - -value_t read_sexpr(FILE *f) -{ - value_t v; - - switch (peek(f)) { - case TOK_CLOSE: - take(); - lerror("read: error: unexpected ')'\n"); - case TOK_DOT: - take(); - lerror("read: error: unexpected '.'\n"); - case TOK_SYM: - case TOK_NUM: - take(); - return tokval; - case TOK_QUOTE: - take(); - v = read_sexpr(f); - PUSH(v); - v = cons_("E, cons(&Stack[SP - 1], &NIL)); - POPN(2); - return v; - case TOK_OPEN: - take(); - PUSH(NIL); - read_list(f, &Stack[SP - 1]); - return POP(); - } - return NIL; -} - -// print -// ---------------------------------------------------------------------- - -void print(FILE *f, value_t v) -{ - value_t cd; - - switch (tag(v)) { - case TAG_NUM: - fprintf(f, "%ld", numval(v)); - break; - case TAG_SYM: - fprintf(f, "%s", ((symbol_t *)ptr(v))->name); - break; - case TAG_BUILTIN: - fprintf(f, "#", builtin_names[intval(v)]); - break; - case TAG_CONS: - fprintf(f, "("); - while (1) { - print(f, car_(v)); - cd = cdr_(v); - if (!iscons(cd)) { - if (cd != NIL) { - fprintf(f, " . "); - print(f, cd); - } - fprintf(f, ")"); - break; - } - fprintf(f, " "); - v = cd; - } - break; - } -} - -// eval -// ----------------------------------------------------------------------- - -static inline void argcount(char *fname, int nargs, int c) -{ - if (nargs != c) - lerror("%s: error: too %s arguments\n", fname, - nargs < c ? "few" : "many"); -} - -#define eval(e, env) ((tag(e) < 0x2) ? (e) : eval_sexpr((e), env)) -#define tail_eval(xpr, env) \ - do { \ - SP = saveSP; \ - if (tag(xpr) < 0x2) { \ - return (xpr); \ - } else { \ - e = (xpr); \ - *penv = (env); \ - goto eval_top; \ - } \ - } while (0) - -value_t eval_sexpr(value_t e, value_t *penv) -{ - value_t f, v, bind, headsym, asym, labl = 0, *pv, *argsyms, *body, *lenv; - value_t *rest; - cons_t *c; - symbol_t *sym; - u_int32_t saveSP; - int i, nargs, noeval = 0; - number_t s, n; - -eval_top: - if (issymbol(e)) { - sym = (symbol_t *)ptr(e); - if (sym->constant != UNBOUND) - return sym->constant; - v = *penv; - while (iscons(v)) { - bind = car_(v); - if (iscons(bind) && car_(bind) == e) - return cdr_(bind); - v = cdr_(v); - } - if ((v = sym->binding) == UNBOUND) - lerror("eval: error: variable %s has no value\n", sym->name); - return v; - } - if ((unsigned long)(char *)&nargs < (unsigned long)stack_bottom || - SP >= (N_STACK - 100)) - lerror("eval: error: stack overflow\n"); - saveSP = SP; - PUSH(e); - PUSH(*penv); - f = eval(car_(e), penv); - *penv = Stack[saveSP + 1]; - if (isbuiltin(f)) { - // handle builtin function - if (!isspecial(f)) { - // evaluate argument list, placing arguments on stack - v = Stack[saveSP] = cdr_(Stack[saveSP]); - while (iscons(v)) { - v = eval(car_(v), penv); - *penv = Stack[saveSP + 1]; - PUSH(v); - v = Stack[saveSP] = cdr_(Stack[saveSP]); - } - } - apply_builtin: - nargs = SP - saveSP - 2; - switch (intval(f)) { - // special forms - case F_QUOTE: - v = cdr_(Stack[saveSP]); - if (!iscons(v)) - lerror("quote: error: expected argument\n"); - v = car_(v); - break; - case F_MACRO: - case F_LAMBDA: - v = Stack[saveSP]; - if (*penv != NIL) { - // build a closure (lambda args body . env) - v = cdr_(v); - PUSH(car(v)); - argsyms = &Stack[SP - 1]; - PUSH(car(cdr_(v))); - body = &Stack[SP - 1]; - v = cons_(intval(f) == F_LAMBDA ? &LAMBDA : &MACRO, - cons(argsyms, cons(body, penv))); - } - break; - case F_LABEL: - v = Stack[saveSP]; - if (*penv != NIL) { - v = cdr_(v); - PUSH(car(v)); // name - pv = &Stack[SP - 1]; - PUSH(car(cdr_(v))); // function - body = &Stack[SP - 1]; - *body = eval(*body, penv); // evaluate lambda - v = cons_(&LABEL, cons(pv, cons(body, &NIL))); - } - break; - case F_IF: - v = car(cdr_(Stack[saveSP])); - if (eval(v, penv) != NIL) - v = car(cdr_(cdr_(Stack[saveSP]))); - else - v = car(cdr(cdr_(cdr_(Stack[saveSP])))); - tail_eval(v, Stack[saveSP + 1]); - break; - case F_COND: - Stack[saveSP] = cdr_(Stack[saveSP]); - pv = &Stack[saveSP]; - v = NIL; - while (iscons(*pv)) { - c = tocons(car_(*pv), "cond"); - v = eval(c->car, penv); - *penv = Stack[saveSP + 1]; - if (v != NIL) { - *pv = cdr_(car_(*pv)); - // evaluate body forms - if (iscons(*pv)) { - while (iscons(cdr_(*pv))) { - v = eval(car_(*pv), penv); - *penv = Stack[saveSP + 1]; - *pv = cdr_(*pv); - } - tail_eval(car_(*pv), *penv); - } - break; - } - *pv = cdr_(*pv); - } - break; - case F_AND: - Stack[saveSP] = cdr_(Stack[saveSP]); - pv = &Stack[saveSP]; - v = T; - if (iscons(*pv)) { - while (iscons(cdr_(*pv))) { - if ((v = eval(car_(*pv), penv)) == NIL) { - SP = saveSP; - return NIL; - } - *penv = Stack[saveSP + 1]; - *pv = cdr_(*pv); - } - tail_eval(car_(*pv), *penv); - } - break; - case F_OR: - Stack[saveSP] = cdr_(Stack[saveSP]); - pv = &Stack[saveSP]; - v = NIL; - if (iscons(*pv)) { - while (iscons(cdr_(*pv))) { - if ((v = eval(car_(*pv), penv)) != NIL) { - SP = saveSP; - return v; - } - *penv = Stack[saveSP + 1]; - *pv = cdr_(*pv); - } - tail_eval(car_(*pv), *penv); - } - break; - case F_WHILE: - PUSH(cdr(cdr_(Stack[saveSP]))); - body = &Stack[SP - 1]; - PUSH(*body); - Stack[saveSP] = car_(cdr_(Stack[saveSP])); - value_t *cond = &Stack[saveSP]; - PUSH(NIL); - pv = &Stack[SP - 1]; - while (eval(*cond, penv) != NIL) { - *penv = Stack[saveSP + 1]; - *body = Stack[SP - 2]; - while (iscons(*body)) { - *pv = eval(car_(*body), penv); - *penv = Stack[saveSP + 1]; - *body = cdr_(*body); - } - } - v = *pv; - break; - case F_PROGN: - // return last arg - Stack[saveSP] = cdr_(Stack[saveSP]); - pv = &Stack[saveSP]; - v = NIL; - if (iscons(*pv)) { - while (iscons(cdr_(*pv))) { - v = eval(car_(*pv), penv); - *penv = Stack[saveSP + 1]; - *pv = cdr_(*pv); - } - tail_eval(car_(*pv), *penv); - } - break; - - // ordinary functions - case F_SET: - argcount("set", nargs, 2); - e = Stack[SP - 2]; - v = *penv; - while (iscons(v)) { - bind = car_(v); - if (iscons(bind) && car_(bind) == e) { - cdr_(bind) = (v = Stack[SP - 1]); - SP = saveSP; - return v; - } - v = cdr_(v); - } - tosymbol(e, "set")->binding = (v = Stack[SP - 1]); - break; - case F_BOUNDP: - argcount("boundp", nargs, 1); - sym = tosymbol(Stack[SP - 1], "boundp"); - if (sym->binding == UNBOUND && sym->constant == UNBOUND) - v = NIL; - else - v = T; - break; - case F_EQ: - argcount("eq", nargs, 2); - v = ((Stack[SP - 2] == Stack[SP - 1]) ? T : NIL); - break; - case F_CONS: - argcount("cons", nargs, 2); - v = mk_cons(); - car_(v) = Stack[SP - 2]; - cdr_(v) = Stack[SP - 1]; - break; - case F_CAR: - argcount("car", nargs, 1); - v = car(Stack[SP - 1]); - break; - case F_CDR: - argcount("cdr", nargs, 1); - v = cdr(Stack[SP - 1]); - break; - case F_RPLACA: - argcount("rplaca", nargs, 2); - car(v = Stack[SP - 2]) = Stack[SP - 1]; - break; - case F_RPLACD: - argcount("rplacd", nargs, 2); - cdr(v = Stack[SP - 2]) = Stack[SP - 1]; - break; - case F_ATOM: - argcount("atom", nargs, 1); - v = ((!iscons(Stack[SP - 1])) ? T : NIL); - break; - case F_SYMBOLP: - argcount("symbolp", nargs, 1); - v = ((issymbol(Stack[SP - 1])) ? T : NIL); - break; - case F_NUMBERP: - argcount("numberp", nargs, 1); - v = ((isnumber(Stack[SP - 1])) ? T : NIL); - break; - case F_ADD: - s = 0; - for (i = saveSP + 2; i < (int)SP; i++) { - n = tonumber(Stack[i], "+"); - s += n; - } - v = number(s); - break; - case F_SUB: - if (nargs < 1) - lerror("-: error: too few arguments\n"); - i = saveSP + 2; - s = (nargs == 1) ? 0 : tonumber(Stack[i++], "-"); - for (; i < (int)SP; i++) { - n = tonumber(Stack[i], "-"); - s -= n; - } - v = number(s); - break; - case F_MUL: - s = 1; - for (i = saveSP + 2; i < (int)SP; i++) { - n = tonumber(Stack[i], "*"); - s *= n; - } - v = number(s); - break; - case F_DIV: - if (nargs < 1) - lerror("/: error: too few arguments\n"); - i = saveSP + 2; - s = (nargs == 1) ? 1 : tonumber(Stack[i++], "/"); - for (; i < (int)SP; i++) { - n = tonumber(Stack[i], "/"); - if (n == 0) - lerror("/: error: division by zero\n"); - s /= n; - } - v = number(s); - break; - case F_LT: - argcount("<", nargs, 2); - if (tonumber(Stack[SP - 2], "<") < tonumber(Stack[SP - 1], "<")) - v = T; - else - v = NIL; - break; - case F_NOT: - argcount("not", nargs, 1); - v = ((Stack[SP - 1] == NIL) ? T : NIL); - break; - case F_EVAL: - argcount("eval", nargs, 1); - v = Stack[SP - 1]; - tail_eval(v, NIL); - break; - case F_PRINT: - for (i = saveSP + 2; i < (int)SP; i++) - print(stdout, v = Stack[i]); - break; - case F_READ: - argcount("read", nargs, 0); - v = read_sexpr(stdin); - break; - case F_LOAD: - argcount("load", nargs, 1); - v = load_file(tosymbol(Stack[SP - 1], "load")->name); - break; - case F_PROG1: - // return first arg - if (nargs < 1) - lerror("prog1: error: too few arguments\n"); - v = Stack[saveSP + 2]; - break; - case F_APPLY: - argcount("apply", nargs, 2); - v = Stack[saveSP] = Stack[SP - 1]; // second arg is new arglist - f = Stack[SP - 2]; // first arg is new function - POPN(2); // pop apply's args - if (isbuiltin(f)) { - if (isspecial(f)) - lerror("apply: error: cannot apply special operator " - "%s\n", - builtin_names[intval(f)]); - // unpack arglist onto the stack - while (iscons(v)) { - PUSH(car_(v)); - v = cdr_(v); - } - goto apply_builtin; - } - noeval = 1; - goto apply_lambda; - } - SP = saveSP; - return v; - } else { - v = Stack[saveSP] = cdr_(Stack[saveSP]); - } -apply_lambda: - if (iscons(f)) { - headsym = car_(f); - if (headsym == LABEL) { - // (label name (lambda ...)) behaves the same as the lambda - // alone, except with name bound to the whole label expression - labl = f; - f = car(cdr(cdr_(labl))); - headsym = car(f); - } - // apply lambda or macro expression - PUSH(cdr(cdr(cdr_(f)))); - lenv = &Stack[SP - 1]; - PUSH(car_(cdr_(f))); - argsyms = &Stack[SP - 1]; - PUSH(car_(cdr_(cdr_(f)))); - body = &Stack[SP - 1]; - if (labl) { - // add label binding to environment - PUSH(labl); - PUSH(car_(cdr_(labl))); - *lenv = cons_(cons(&Stack[SP - 1], &Stack[SP - 2]), lenv); - POPN(3); - v = Stack[saveSP]; // refetch arglist - } - if (headsym == MACRO) - noeval = 1; - else if (headsym != LAMBDA) - lerror("apply: error: head must be lambda, macro, or label\n"); - // build a calling environment for the lambda - // the environment is the argument binds on top of the captured - // environment - while (iscons(v)) { - // bind args - if (!iscons(*argsyms)) { - if (*argsyms == NIL) - lerror("apply: error: too many arguments\n"); - break; - } - asym = car_(*argsyms); - if (!issymbol(asym)) - lerror("apply: error: formal argument not a symbol\n"); - v = car_(v); - if (!noeval) { - v = eval(v, penv); - *penv = Stack[saveSP + 1]; - } - PUSH(v); - *lenv = cons_(cons(&asym, &Stack[SP - 1]), lenv); - POPN(2); - *argsyms = cdr_(*argsyms); - v = Stack[saveSP] = cdr_(Stack[saveSP]); - } - if (*argsyms != NIL) { - if (issymbol(*argsyms)) { - if (noeval) { - *lenv = cons_(cons(argsyms, &Stack[saveSP]), lenv); - } else { - PUSH(NIL); - PUSH(NIL); - rest = &Stack[SP - 1]; - // build list of rest arguments - // we have to build it forwards, which is tricky - while (iscons(v)) { - v = eval(car_(v), penv); - *penv = Stack[saveSP + 1]; - PUSH(v); - v = cons_(&Stack[SP - 1], &NIL); - POP(); - if (iscons(*rest)) - cdr_(*rest) = v; - else - Stack[SP - 2] = v; - *rest = v; - v = Stack[saveSP] = cdr_(Stack[saveSP]); - } - *lenv = cons_(cons(argsyms, &Stack[SP - 2]), lenv); - } - } else if (iscons(*argsyms)) { - lerror("apply: error: too few arguments\n"); - } - } - noeval = 0; - // macro: evaluate expansion in the calling environment - if (headsym == MACRO) { - SP = saveSP; - PUSH(*lenv); - lenv = &Stack[SP - 1]; - v = eval(*body, lenv); - tail_eval(v, *penv); - } else { - tail_eval(*body, *lenv); - } - // not reached - } - type_error("apply", "function", f); - return NIL; -} - -// repl -// ----------------------------------------------------------------------- - -static char *infile = NULL; - -value_t toplevel_eval(value_t expr) -{ - value_t v; - u_int32_t saveSP = SP; - PUSH(NIL); - v = eval(expr, &Stack[SP - 1]); - SP = saveSP; - return v; -} - -value_t load_file(char *fname) -{ - value_t e, v = NIL; - char *lastfile = infile; - FILE *f = fopen(fname, "r"); - infile = fname; - if (f == NULL) - lerror("file not found\n"); - while (1) { - e = read_sexpr(f); - if (feof(f)) - break; - v = toplevel_eval(e); - } - infile = lastfile; - fclose(f); - return v; -} - -int main(int argc, char *argv[]) -{ - value_t v; - - stack_bottom = ((char *)&v) - PROCESS_STACK_SIZE; - lisp_init(); - if (setjmp(toplevel)) { - SP = 0; - fprintf(stderr, "\n"); - if (infile) { - fprintf(stderr, "error loading file \"%s\"\n", infile); - infile = NULL; - } - goto repl; - } - load_file("system.lsp"); - if (argc > 1) { - load_file(argv[1]); - return 0; - } - printf("Welcome to femtoLisp " - "----------------------------------------------------------\n"); -repl: - while (1) { - printf("> "); - v = read_sexpr(stdin); - if (feof(stdin)) - break; - print(stdout, v = toplevel_eval(v)); - set(symbol("that"), v); - printf("\n\n"); - } - return 0; -} diff --git a/tiny/lisp2.c b/tiny/lisp2.c deleted file mode 100644 index 16049f1..0000000 --- a/tiny/lisp2.c +++ /dev/null @@ -1,1525 +0,0 @@ -/* - femtoLisp - - a minimal interpreter for a minimal lisp dialect - - this lisp dialect uses lexical scope and self-evaluating lambda. - it supports 30-bit integers, symbols, conses, and full macros. - it is case-sensitive. - it features a simple compacting copying garbage collector. - it uses a Scheme-style evaluation rule where any expression may appear in - head position as long as it evaluates to a function. - it uses Scheme-style varargs (dotted formal argument lists) - lambdas can have only 1 body expression; use (progn ...) for multiple - expressions. this is due to the closure representation - (lambda args body . env) - - This is a fork of femtoLisp with advanced reading and printing facilities: - * circular structure can be printed and read - * #. read macro for eval-when-read and correctly printing builtins - * read macros for backquote - * symbol character-escaping printer - - * new print algorithm - 1. traverse & tag all conses to be printed. when you encounter a cons - that is already tagged, add it to a table to give it a #n# index - 2. untag a cons when printing it. if cons is in the table, print - "#n=" before it in the car, " . #n=" in the cdr. if cons is in the - table but already untagged, print #n# in car or " . #n#" in the cdr. - * read macros for #n# and #n= using the same kind of table - * also need a table of read labels to translate from input indexes to - normalized indexes (0 for first label, 1 for next, etc.) - * read macro #. for eval-when-read. use for printing builtins, e.g. "#.eq" - - The value of this extra complexity, and what makes this fork worthy of - the femtoLisp brand, is that the interpreter is fully "closed" in the - sense that all representable values can be read and printed. - - by Jeff Bezanson - Public Domain -*/ - -#include -#include -#include -#include -#include -#include -#include - -typedef u_int32_t value_t; -typedef int32_t number_t; - -typedef struct { - value_t car; - value_t cdr; -} cons_t; - -typedef struct _symbol_t { - value_t binding; // global value binding - value_t constant; // constant binding (used only for builtins) - struct _symbol_t *left; - struct _symbol_t *right; - char name[1]; -} symbol_t; - -#define TAG_NUM 0x0 -#define TAG_BUILTIN 0x1 -#define TAG_SYM 0x2 -#define TAG_CONS 0x3 -#define UNBOUND ((value_t)TAG_SYM) // an invalid symbol pointer -#define tag(x) ((x)&0x3) -#define ptr(x) ((void *)((x) & (~(value_t)0x3))) -#define tagptr(p, t) (((value_t)(p)) | (t)) -#define number(x) ((value_t)((x) << 2)) -#define numval(x) (((number_t)(x)) >> 2) -#define intval(x) (((int)(x)) >> 2) -#define builtin(n) tagptr((((int)n) << 2), TAG_BUILTIN) -#define iscons(x) (tag(x) == TAG_CONS) -#define issymbol(x) (tag(x) == TAG_SYM) -#define isnumber(x) (tag(x) == TAG_NUM) -#define isbuiltin(x) (tag(x) == TAG_BUILTIN) -// functions ending in _ are unsafe, faster versions -#define car_(v) (((cons_t *)ptr(v))->car) -#define cdr_(v) (((cons_t *)ptr(v))->cdr) -#define car(v) (tocons((v), "car")->car) -#define cdr(v) (tocons((v), "cdr")->cdr) -#define set(s, v) (((symbol_t *)ptr(s))->binding = (v)) -#define setc(s, v) (((symbol_t *)ptr(s))->constant = (v)) - -enum { - // special forms - F_QUOTE = 0, - F_COND, - F_IF, - F_AND, - F_OR, - F_WHILE, - F_LAMBDA, - F_MACRO, - F_LABEL, - F_PROGN, - // functions - F_EQ, - F_ATOM, - F_CONS, - F_CAR, - F_CDR, - F_READ, - F_EVAL, - F_PRINT, - F_SET, - F_NOT, - F_LOAD, - F_SYMBOLP, - F_NUMBERP, - F_ADD, - F_SUB, - F_MUL, - F_DIV, - F_LT, - F_PROG1, - F_APPLY, - F_RPLACA, - F_RPLACD, - F_BOUNDP, - F_ERROR, - F_EXIT, - F_PRINC, - F_CONSP, - F_ASSOC, - N_BUILTINS -}; -#define isspecial(v) (intval(v) <= (number_t)F_PROGN) - -static char *builtin_names[] = { - "quote", "cond", "if", "and", "or", "while", "lambda", - "macro", "label", "progn", "eq", "atom", "cons", "car", - "cdr", "read", "eval", "print", "set", "not", "load", - "symbolp", "numberp", "+", "-", "*", "/", "<", - "prog1", "apply", "rplaca", "rplacd", "boundp", "error", "exit", - "princ", "consp", "assoc" -}; - -static char *stack_bottom; -#define PROCESS_STACK_SIZE (2 * 1024 * 1024) -#define N_STACK 98304 -static value_t Stack[N_STACK]; -static u_int32_t SP = 0; -#define PUSH(v) (Stack[SP++] = (v)) -#define POP() (Stack[--SP]) -#define POPN(n) (SP -= (n)) - -value_t NIL, T, LAMBDA, MACRO, LABEL, QUOTE; -value_t BACKQUOTE, COMMA, COMMAAT, COMMADOT; - -value_t read_sexpr(FILE *f); -void print(FILE *f, value_t v, int princ); -value_t eval_sexpr(value_t e, value_t *penv, int tail, u_int32_t envend); -value_t load_file(char *fname); -value_t toplevel_eval(value_t expr); - -#include "flutils.c" - -typedef struct _readstate_t { - ltable_t labels; - ltable_t exprs; - struct _readstate_t *prev; -} readstate_t; -static readstate_t *readstate = NULL; - -// error utilities -// ------------------------------------------------------------ - -jmp_buf toplevel; - -void lerror(char *format, ...) -{ - va_list args; - va_start(args, format); - - while (readstate) { - free(readstate->labels.items); - free(readstate->exprs.items); - readstate = readstate->prev; - } - - vfprintf(stderr, format, args); - va_end(args); - longjmp(toplevel, 1); -} - -void type_error(char *fname, char *expected, value_t got) -{ - fprintf(stderr, "%s: error: expected %s, got ", fname, expected); - print(stderr, got, 0); - lerror("\n"); -} - -// safe cast operators -// -------------------------------------------------------- - -#define SAFECAST_OP(type, ctype, cnvt) \ - ctype to##type(value_t v, char *fname) \ - { \ - if (is##type(v)) \ - return (ctype)cnvt(v); \ - type_error(fname, #type, v); \ - return (ctype)0; \ - } -SAFECAST_OP(cons, cons_t *, ptr) -SAFECAST_OP(symbol, symbol_t *, ptr) -SAFECAST_OP(number, number_t, numval) - -// symbol table -// --------------------------------------------------------------- - -static symbol_t *symtab = NULL; - -static symbol_t *mk_symbol(char *str) -{ - symbol_t *sym; - - sym = (symbol_t *)malloc(sizeof(symbol_t) + strlen(str)); - sym->left = sym->right = NULL; - sym->constant = sym->binding = UNBOUND; - strcpy(&sym->name[0], str); - return sym; -} - -static symbol_t **symtab_lookup(symbol_t **ptree, char *str) -{ - int x; - - while (*ptree != NULL) { - x = strcmp(str, (*ptree)->name); - if (x == 0) - return ptree; - if (x < 0) - ptree = &(*ptree)->left; - else - ptree = &(*ptree)->right; - } - return ptree; -} - -value_t symbol(char *str) -{ - symbol_t **pnode; - - pnode = symtab_lookup(&symtab, str); - if (*pnode == NULL) - *pnode = mk_symbol(str); - return tagptr(*pnode, TAG_SYM); -} - -// initialization -// ------------------------------------------------------------- - -static unsigned char *fromspace; -static unsigned char *tospace; -static unsigned char *curheap; -static unsigned char *lim; -static u_int32_t heapsize = 128 * 1024; // bytes -static u_int32_t *consflags; -static ltable_t printconses; - -void lisp_init(void) -{ - int i; - - fromspace = malloc(heapsize); - tospace = malloc(heapsize); - curheap = fromspace; - lim = curheap + heapsize - sizeof(cons_t); - consflags = mk_bitvector(heapsize / sizeof(cons_t)); - - ltable_init(&printconses, 32); - - NIL = symbol("nil"); - setc(NIL, NIL); - T = symbol("t"); - setc(T, T); - LAMBDA = symbol("lambda"); - MACRO = symbol("macro"); - LABEL = symbol("label"); - QUOTE = symbol("quote"); - BACKQUOTE = symbol("backquote"); - COMMA = symbol("*comma*"); - COMMAAT = symbol("*comma-at*"); - COMMADOT = symbol("*comma-dot*"); - for (i = 0; i < (int)N_BUILTINS; i++) - setc(symbol(builtin_names[i]), builtin(i)); -} - -// conses -// --------------------------------------------------------------------- - -void gc(int mustgrow); - -static value_t mk_cons(void) -{ - cons_t *c; - - if (curheap > lim) - gc(0); - c = (cons_t *)curheap; - curheap += sizeof(cons_t); - return tagptr(c, TAG_CONS); -} - -// allocate n consecutive conses -static value_t cons_reserve(int n) -{ - cons_t *first; - - n--; - if ((cons_t *)curheap > ((cons_t *)lim) - n) { - gc(0); - while ((cons_t *)curheap > ((cons_t *)lim) - n) { - gc(1); - } - } - first = (cons_t *)curheap; - curheap += ((n + 1) * sizeof(cons_t)); - return tagptr(first, TAG_CONS); -} - -#define cons_index(c) (((cons_t *)ptr(c)) - ((cons_t *)fromspace)) -#define ismarked(c) bitvector_get(consflags, cons_index(c)) -#define mark_cons(c) bitvector_set(consflags, cons_index(c), 1) -#define unmark_cons(c) bitvector_set(consflags, cons_index(c), 0) - -// collector -// ------------------------------------------------------------------ - -static value_t relocate(value_t v) -{ - value_t a, d, nc, first, *pcdr; - - if (!iscons(v)) - return v; - // iterative implementation allows arbitrarily long cons chains - pcdr = &first; - do { - if ((a = car_(v)) == UNBOUND) { - *pcdr = cdr_(v); - return first; - } - *pcdr = nc = mk_cons(); - d = cdr_(v); - car_(v) = UNBOUND; - cdr_(v) = nc; - car_(nc) = relocate(a); - pcdr = &cdr_(nc); - v = d; - } while (iscons(v)); - *pcdr = d; - - return first; -} - -static void trace_globals(symbol_t *root) -{ - while (root != NULL) { - root->binding = relocate(root->binding); - trace_globals(root->left); - root = root->right; - } -} - -void gc(int mustgrow) -{ - static int grew = 0; - void *temp; - u_int32_t i; - readstate_t *rs; - - curheap = tospace; - lim = curheap + heapsize - sizeof(cons_t); - - for (i = 0; i < SP; i++) - Stack[i] = relocate(Stack[i]); - trace_globals(symtab); - rs = readstate; - while (rs) { - for (i = 0; i < rs->exprs.n; i++) - rs->exprs.items[i] = relocate(rs->exprs.items[i]); - rs = rs->prev; - } -#ifdef VERBOSEGC - printf("gc found %d/%d live conses\n", - (curheap - tospace) / sizeof(cons_t), heapsize / sizeof(cons_t)); -#endif - temp = tospace; - tospace = fromspace; - fromspace = temp; - - // if we're using > 80% of the space, resize tospace so we have - // more space to fill next time. if we grew tospace last time, - // grow the other half of the heap this time to catch up. - if (grew || ((lim - curheap) < (int)(heapsize / 5)) || mustgrow) { - temp = realloc(tospace, grew ? heapsize : heapsize * 2); - if (temp == NULL) - lerror("out of memory\n"); - tospace = temp; - if (!grew) { - heapsize *= 2; - } else { - temp = bitvector_resize(consflags, heapsize / sizeof(cons_t)); - if (temp == NULL) - lerror("out of memory\n"); - consflags = (u_int32_t *)temp; - } - grew = !grew; - } - if (curheap > lim) // all data was live - gc(0); -} - -// read -// ----------------------------------------------------------------------- - -enum { - TOK_NONE, - TOK_OPEN, - TOK_CLOSE, - TOK_DOT, - TOK_QUOTE, - TOK_SYM, - TOK_NUM, - TOK_BQ, - TOK_COMMA, - TOK_COMMAAT, - TOK_COMMADOT, - TOK_SHARPDOT, - TOK_LABEL, - TOK_BACKREF, - TOK_SHARPQUOTE -}; - -// defines which characters are ordinary symbol characters. -// the only exception is '.', which is an ordinary symbol character -// unless it is the only character in the symbol. -static int symchar(char c) -{ - static char *special = "()';`,\\|"; - return (!isspace(c) && !strchr(special, c)); -} - -static u_int32_t toktype = TOK_NONE; -static value_t tokval; -static char buf[256]; - -static char nextchar(FILE *f) -{ - int ch; - char c; - - do { - ch = fgetc(f); - if (ch == EOF) - return 0; - c = (char)ch; - if (c == ';') { - // single-line comment - do { - ch = fgetc(f); - if (ch == EOF) - return 0; - } while ((char)ch != '\n'); - c = (char)ch; - } - } while (isspace(c)); - return c; -} - -static void take(void) { toktype = TOK_NONE; } - -static void accumchar(char c, int *pi) -{ - buf[(*pi)++] = c; - if (*pi >= (int)(sizeof(buf) - 1)) - lerror("read: error: token too long\n"); -} - -// return: 1 for dot token, 0 for symbol -static int read_token(FILE *f, char c, int digits) -{ - int i = 0, ch, escaped = 0, dot = (c == '.'), totread = 0; - - ungetc(c, f); - while (1) { - ch = fgetc(f); - totread++; - if (ch == EOF) - goto terminate; - c = (char)ch; - if (c == '|') { - escaped = !escaped; - } else if (c == '\\') { - ch = fgetc(f); - if (ch == EOF) - goto terminate; - accumchar((char)ch, &i); - } else if (!escaped && !(symchar(c) && (!digits || isdigit(c)))) { - break; - } else { - accumchar(c, &i); - } - } - ungetc(c, f); -terminate: - buf[i++] = '\0'; - return (dot && (totread == 2)); -} - -static u_int32_t peek(FILE *f) -{ - char c, *end; - number_t x; - int ch; - - if (toktype != TOK_NONE) - return toktype; - c = nextchar(f); - if (feof(f)) - return TOK_NONE; - if (c == '(') { - toktype = TOK_OPEN; - } else if (c == ')') { - toktype = TOK_CLOSE; - } else if (c == '\'') { - toktype = TOK_QUOTE; - } else if (c == '`') { - toktype = TOK_BQ; - } else if (c == '#') { - ch = fgetc(f); - if (ch == EOF) - lerror("read: error: invalid read macro\n"); - if ((char)ch == '.') { - toktype = TOK_SHARPDOT; - } else if ((char)ch == '\'') { - toktype = TOK_SHARPQUOTE; - } else if ((char)ch == '\\') { - u_int32_t cval = u8_fgetc(f); - toktype = TOK_NUM; - tokval = number(cval); - } else if (isdigit((char)ch)) { - read_token(f, (char)ch, 1); - c = (char)fgetc(f); - if (c == '#') - toktype = TOK_BACKREF; - else if (c == '=') - toktype = TOK_LABEL; - else - lerror("read: error: invalid label\n"); - x = strtol(buf, &end, 10); - tokval = number(x); - } else { - lerror("read: error: unknown read macro\n"); - } - } else if (c == ',') { - toktype = TOK_COMMA; - ch = fgetc(f); - if (ch == EOF) - return toktype; - if ((char)ch == '@') - toktype = TOK_COMMAAT; - else if ((char)ch == '.') - toktype = TOK_COMMADOT; - else - ungetc((char)ch, f); - } else if (isdigit(c) || c == '-' || c == '+') { - read_token(f, c, 0); - x = strtol(buf, &end, 0); - if (*end != '\0') { - toktype = TOK_SYM; - tokval = symbol(buf); - } else { - toktype = TOK_NUM; - tokval = number(x); - } - } else { - if (read_token(f, c, 0)) { - toktype = TOK_DOT; - } else { - toktype = TOK_SYM; - tokval = symbol(buf); - } - } - return toktype; -} - -static value_t do_read_sexpr(FILE *f, int fixup); - -// build a list of conses. this is complicated by the fact that all conses -// can move whenever a new cons is allocated. we have to refer to every cons -// through a handle to a relocatable pointer (i.e. a pointer on the stack). -static void read_list(FILE *f, value_t *pval, int fixup) -{ - value_t c, *pc; - u_int32_t t; - - PUSH(NIL); - pc = &Stack[SP - 1]; // to keep track of current cons cell - t = peek(f); - while (t != TOK_CLOSE) { - if (feof(f)) - lerror("read: error: unexpected end of input\n"); - c = mk_cons(); - car_(c) = cdr_(c) = NIL; - if (iscons(*pc)) { - cdr_(*pc) = c; - } else { - *pval = c; - if (fixup != -1) - readstate->exprs.items[fixup] = c; - } - *pc = c; - c = - do_read_sexpr(f, -1); // must be on separate lines due to undefined - car_(*pc) = c; // evaluation order - - t = peek(f); - if (t == TOK_DOT) { - take(); - c = do_read_sexpr(f, -1); - cdr_(*pc) = c; - t = peek(f); - if (feof(f)) - lerror("read: error: unexpected end of input\n"); - if (t != TOK_CLOSE) - lerror("read: error: expected ')'\n"); - } - } - take(); - POP(); -} - -// fixup is the index of the label we'd like to fix up with this read -static value_t do_read_sexpr(FILE *f, int fixup) -{ - value_t v, *head; - u_int32_t t, l; - int i; - - t = peek(f); - take(); - switch (t) { - case TOK_CLOSE: - lerror("read: error: unexpected ')'\n"); - case TOK_DOT: - lerror("read: error: unexpected '.'\n"); - case TOK_SYM: - case TOK_NUM: - return tokval; - case TOK_COMMA: - head = &COMMA; - goto listwith; - case TOK_COMMAAT: - head = &COMMAAT; - goto listwith; - case TOK_COMMADOT: - head = &COMMADOT; - goto listwith; - case TOK_BQ: - head = &BACKQUOTE; - goto listwith; - case TOK_QUOTE: - head = "E; - listwith: - v = cons_reserve(2); - car_(v) = *head; - cdr_(v) = tagptr(((cons_t *)ptr(v)) + 1, TAG_CONS); - car_(cdr_(v)) = cdr_(cdr_(v)) = NIL; - PUSH(v); - if (fixup != -1) - readstate->exprs.items[fixup] = v; - v = do_read_sexpr(f, -1); - car_(cdr_(Stack[SP - 1])) = v; - return POP(); - case TOK_SHARPQUOTE: - // femtoLisp doesn't need symbol-function, so #' does nothing - return do_read_sexpr(f, fixup); - case TOK_OPEN: - PUSH(NIL); - read_list(f, &Stack[SP - 1], fixup); - return POP(); - case TOK_SHARPDOT: - // eval-when-read - // evaluated expressions can refer to existing backreferences, but - // they cannot see pending labels. in other words: - // (... #2=#.#0# ... ) OK - // (... #2=#.(#2#) ... ) DO NOT WANT - v = do_read_sexpr(f, -1); - return toplevel_eval(v); - case TOK_LABEL: - // create backreference label - l = numval(tokval); - if (ltable_lookup(&readstate->labels, l) != NOTFOUND) - lerror("read: error: label %d redefined\n", l); - ltable_insert(&readstate->labels, l); - i = readstate->exprs.n; - ltable_insert(&readstate->exprs, UNBOUND); - v = do_read_sexpr(f, i); - readstate->exprs.items[i] = v; - return v; - case TOK_BACKREF: - // look up backreference - l = numval(tokval); - i = ltable_lookup(&readstate->labels, l); - if (i == NOTFOUND || i >= (int)readstate->exprs.n || - readstate->exprs.items[i] == UNBOUND) - lerror("read: error: undefined label %d\n", l); - return readstate->exprs.items[i]; - } - return NIL; -} - -value_t read_sexpr(FILE *f) -{ - value_t v; - readstate_t state; - state.prev = readstate; - ltable_init(&state.labels, 16); - ltable_init(&state.exprs, 16); - readstate = &state; - - v = do_read_sexpr(f, -1); - - readstate = state.prev; - free(state.labels.items); - free(state.exprs.items); - return v; -} - -// print -// ---------------------------------------------------------------------- - -static void print_traverse(value_t v) -{ - while (iscons(v)) { - if (ismarked(v)) { - ltable_adjoin(&printconses, v); - return; - } - mark_cons(v); - print_traverse(car_(v)); - v = cdr_(v); - } -} - -static void print_symbol(FILE *f, char *name) -{ - int i, escape = 0, charescape = 0; - - if (name[0] == '\0') { - fprintf(f, "||"); - return; - } - if (name[0] == '.' && name[1] == '\0') { - fprintf(f, "|.|"); - return; - } - if (name[0] == '#') - escape = 1; - i = 0; - while (name[i]) { - if (!symchar(name[i])) { - escape = 1; - if (name[i] == '|' || name[i] == '\\') { - charescape = 1; - break; - } - } - i++; - } - if (escape) { - if (charescape) { - fprintf(f, "|"); - i = 0; - while (name[i]) { - if (name[i] == '|' || name[i] == '\\') - fprintf(f, "\\%c", name[i]); - else - fprintf(f, "%c", name[i]); - i++; - } - fprintf(f, "|"); - } else { - fprintf(f, "|%s|", name); - } - } else { - fprintf(f, "%s", name); - } -} - -static void do_print(FILE *f, value_t v, int princ) -{ - value_t cd; - int label; - char *name; - - switch (tag(v)) { - case TAG_NUM: - fprintf(f, "%d", numval(v)); - break; - case TAG_SYM: - name = ((symbol_t *)ptr(v))->name; - if (princ) - fprintf(f, "%s", name); - else - print_symbol(f, name); - break; - case TAG_BUILTIN: - fprintf(f, "#.%s", builtin_names[intval(v)]); - break; - case TAG_CONS: - if ((label = ltable_lookup(&printconses, v)) != NOTFOUND) { - if (!ismarked(v)) { - fprintf(f, "#%d#", label); - return; - } - fprintf(f, "#%d=", label); - } - fprintf(f, "("); - while (1) { - unmark_cons(v); - do_print(f, car_(v), princ); - cd = cdr_(v); - if (!iscons(cd)) { - if (cd != NIL) { - fprintf(f, " . "); - do_print(f, cd, princ); - } - fprintf(f, ")"); - break; - } else { - if ((label = ltable_lookup(&printconses, cd)) != NOTFOUND) { - fprintf(f, " . "); - do_print(f, cd, princ); - fprintf(f, ")"); - break; - } - } - fprintf(f, " "); - v = cd; - } - break; - } -} - -void print(FILE *f, value_t v, int princ) -{ - ltable_clear(&printconses); - print_traverse(v); - do_print(f, v, princ); -} - -// eval -// ----------------------------------------------------------------------- - -static inline void argcount(char *fname, int nargs, int c) -{ - if (nargs != c) - lerror("%s: error: too %s arguments\n", fname, - nargs < c ? "few" : "many"); -} - -// return a cons element of v whose car is item -static value_t assoc(value_t item, value_t v) -{ - value_t bind; - - while (iscons(v)) { - bind = car_(v); - if (iscons(bind) && car_(bind) == item) - return bind; - v = cdr_(v); - } - return NIL; -} - -#define eval(e) ((tag(e) < 0x2) ? (e) : eval_sexpr((e), penv, 0, envend)) -#define topeval(e, env) ((tag(e) < 0x2) ? (e) : eval_sexpr((e), env, 1, SP)) -#define tail_eval(xpr) \ - do { \ - SP = saveSP; \ - if (tag(xpr) < 0x2) { \ - return (xpr); \ - } else { \ - e = (xpr); \ - goto eval_top; \ - } \ - } while (0) - -/* stack setup on entry: - n n+1 ... - +-----+-----+-----+-----+-----+-----+-----+-----+ - | SYM | VAL | SYM | VAL | CLO | | | | - +-----+-----+-----+-----+-----+-----+-----+-----+ - ^ ^ ^ - | | | - penv envend SP (who knows where) - - sym is an argument name and val is its binding. CLO is a closed-up - environment list (which can be empty, i.e. NIL). - CLO is always there, but there might be zero SYM/VAL pairs. - - if tail==1, you are allowed (indeed encouraged) to overwrite this - environment, otherwise you have to put any new environment on the top - of the stack. -*/ -value_t eval_sexpr(value_t e, value_t *penv, int tail, u_int32_t envend) -{ - value_t f, v, headsym, asym, *pv, *argsyms, *body, *lenv, *argenv; - cons_t *c; - symbol_t *sym; - u_int32_t saveSP; - int i, nargs, noeval = 0; - number_t s, n; - -eval_top: - if (issymbol(e)) { - sym = (symbol_t *)ptr(e); - if (sym->constant != UNBOUND) - return sym->constant; - while (issymbol(*penv)) { // 1. try lookup in argument env - if (*penv == NIL) - goto get_global; - if (*penv == e) - return penv[1]; - penv += 2; - } - if ((v = assoc(e, *penv)) != NIL) // 2. closure env - return cdr_(v); - get_global: - if ((v = sym->binding) == UNBOUND) // 3. global env - lerror("eval: error: variable %s has no value\n", sym->name); - return v; - } - if ((unsigned)(char *)&nargs < (unsigned)stack_bottom || - SP >= (N_STACK - 100)) - lerror("eval: error: stack overflow\n"); - saveSP = SP; - PUSH(e); - v = car_(e); - if (tag(v) < 0x2) - f = v; - else if (issymbol(v) && (f = ((symbol_t *)ptr(v))->constant) != UNBOUND) - ; - else - f = eval_sexpr(v, penv, 0, envend); - if (isbuiltin(f)) { - // handle builtin function - if (!isspecial(f)) { - // evaluate argument list, placing arguments on stack - v = Stack[saveSP] = cdr_(Stack[saveSP]); - while (iscons(v)) { - v = eval(car_(v)); - PUSH(v); - v = Stack[saveSP] = cdr_(Stack[saveSP]); - } - } - apply_builtin: - nargs = SP - saveSP - 1; - switch (intval(f)) { - // special forms - case F_QUOTE: - v = cdr_(Stack[saveSP]); - if (!iscons(v)) - lerror("quote: error: expected argument\n"); - v = car_(v); - break; - case F_MACRO: - case F_LAMBDA: - // build a closure (lambda args body . env) - if (issymbol(*penv) && *penv != NIL) { - // cons up and save temporary environment - PUSH(Stack[envend - 1]); // passed-in CLOENV - // find out how many new conses we need - nargs = ((int)(&Stack[envend] - penv - 1)) >> 1; - if (nargs) { - lenv = penv; - Stack[SP - 1] = cons_reserve(nargs * 2); - c = (cons_t *)ptr(Stack[SP - 1]); - while (1) { - c->car = tagptr(c + 1, TAG_CONS); - (c + 1)->car = penv[0]; - (c + 1)->cdr = penv[1]; - nargs--; - if (nargs == 0) - break; - penv += 2; - c->cdr = tagptr(c + 2, TAG_CONS); - c += 2; - } - // final cdr points to existing cloenv - c->cdr = Stack[envend - 1]; - // environment representation changed; install - // the new representation so everybody can see it - *lenv = Stack[SP - 1]; - } - } else { - PUSH(*penv); // env has already been captured; share - } - v = cdr_(Stack[saveSP]); - PUSH(car(v)); - PUSH(car(cdr_(v))); - c = (cons_t *)ptr(v = cons_reserve(3)); - c->car = (intval(f) == F_LAMBDA ? LAMBDA : MACRO); - c->cdr = tagptr(c + 1, TAG_CONS); - c++; - c->car = Stack[SP - 2]; // argsyms - c->cdr = tagptr(c + 1, TAG_CONS); - c++; - c->car = Stack[SP - 1]; // body - c->cdr = Stack[SP - 3]; // env - break; - case F_LABEL: - // the syntax of label is (label name (lambda args body)) - // nothing else is guaranteed to work - v = cdr_(Stack[saveSP]); - PUSH(car(v)); - PUSH(car(cdr_(v))); - body = &Stack[SP - 1]; - *body = eval(*body); // evaluate lambda - c = (cons_t *)ptr(cons_reserve(2)); - c->car = Stack[SP - 2]; // name - c->cdr = v = *body; - c++; - c->car = tagptr(c - 1, TAG_CONS); - f = cdr(cdr(v)); - c->cdr = cdr(f); - // add (name . fn) to front of function's environment - cdr_(f) = tagptr(c, TAG_CONS); - break; - case F_IF: - v = car(cdr_(Stack[saveSP])); - if (eval(v) != NIL) - v = car(cdr_(cdr_(Stack[saveSP]))); - else - v = car(cdr(cdr_(cdr_(Stack[saveSP])))); - tail_eval(v); - break; - case F_COND: - Stack[saveSP] = cdr_(Stack[saveSP]); - pv = &Stack[saveSP]; - v = NIL; - while (iscons(*pv)) { - c = tocons(car_(*pv), "cond"); - v = eval(c->car); - if (v != NIL) { - *pv = cdr_(car_(*pv)); - // evaluate body forms - if (iscons(*pv)) { - while (iscons(cdr_(*pv))) { - v = eval(car_(*pv)); - *pv = cdr_(*pv); - } - tail_eval(car_(*pv)); - } - break; - } - *pv = cdr_(*pv); - } - break; - case F_AND: - Stack[saveSP] = cdr_(Stack[saveSP]); - pv = &Stack[saveSP]; - v = T; - if (iscons(*pv)) { - while (iscons(cdr_(*pv))) { - if ((v = eval(car_(*pv))) == NIL) { - SP = saveSP; - return NIL; - } - *pv = cdr_(*pv); - } - tail_eval(car_(*pv)); - } - break; - case F_OR: - Stack[saveSP] = cdr_(Stack[saveSP]); - pv = &Stack[saveSP]; - v = NIL; - if (iscons(*pv)) { - while (iscons(cdr_(*pv))) { - if ((v = eval(car_(*pv))) != NIL) { - SP = saveSP; - return v; - } - *pv = cdr_(*pv); - } - tail_eval(car_(*pv)); - } - break; - case F_WHILE: - PUSH(cdr(cdr_(Stack[saveSP]))); - body = &Stack[SP - 1]; - PUSH(*body); - Stack[saveSP] = car_(cdr_(Stack[saveSP])); - value_t *cond = &Stack[saveSP]; - PUSH(NIL); - pv = &Stack[SP - 1]; - while (eval(*cond) != NIL) { - *body = Stack[SP - 2]; - while (iscons(*body)) { - *pv = eval(car_(*body)); - *body = cdr_(*body); - } - } - v = *pv; - break; - case F_PROGN: - // return last arg - Stack[saveSP] = cdr_(Stack[saveSP]); - pv = &Stack[saveSP]; - v = NIL; - if (iscons(*pv)) { - while (iscons(cdr_(*pv))) { - v = eval(car_(*pv)); - *pv = cdr_(*pv); - } - tail_eval(car_(*pv)); - } - break; - - // ordinary functions - case F_SET: - argcount("set", nargs, 2); - e = Stack[SP - 2]; - while (issymbol(*penv)) { - if (*penv == NIL) - goto set_global; - if (*penv == e) { - penv[1] = Stack[SP - 1]; - SP = saveSP; - return penv[1]; - } - penv += 2; - } - if ((v = assoc(e, *penv)) != NIL) { - cdr_(v) = (e = Stack[SP - 1]); - SP = saveSP; - return e; - } - set_global: - tosymbol(e, "set")->binding = (v = Stack[SP - 1]); - break; - case F_BOUNDP: - argcount("boundp", nargs, 1); - sym = tosymbol(Stack[SP - 1], "boundp"); - if (sym->binding == UNBOUND && sym->constant == UNBOUND) - v = NIL; - else - v = T; - break; - case F_EQ: - argcount("eq", nargs, 2); - v = ((Stack[SP - 2] == Stack[SP - 1]) ? T : NIL); - break; - case F_CONS: - argcount("cons", nargs, 2); - v = mk_cons(); - car_(v) = Stack[SP - 2]; - cdr_(v) = Stack[SP - 1]; - break; - case F_CAR: - argcount("car", nargs, 1); - v = car(Stack[SP - 1]); - break; - case F_CDR: - argcount("cdr", nargs, 1); - v = cdr(Stack[SP - 1]); - break; - case F_RPLACA: - argcount("rplaca", nargs, 2); - car(v = Stack[SP - 2]) = Stack[SP - 1]; - break; - case F_RPLACD: - argcount("rplacd", nargs, 2); - cdr(v = Stack[SP - 2]) = Stack[SP - 1]; - break; - case F_ATOM: - argcount("atom", nargs, 1); - v = ((!iscons(Stack[SP - 1])) ? T : NIL); - break; - case F_CONSP: - argcount("consp", nargs, 1); - v = (iscons(Stack[SP - 1]) ? T : NIL); - break; - case F_SYMBOLP: - argcount("symbolp", nargs, 1); - v = ((issymbol(Stack[SP - 1])) ? T : NIL); - break; - case F_NUMBERP: - argcount("numberp", nargs, 1); - v = ((isnumber(Stack[SP - 1])) ? T : NIL); - break; - case F_ADD: - s = 0; - for (i = saveSP + 1; i < (int)SP; i++) { - n = tonumber(Stack[i], "+"); - s += n; - } - v = number(s); - break; - case F_SUB: - if (nargs < 1) - lerror("-: error: too few arguments\n"); - i = saveSP + 1; - s = (nargs == 1) ? 0 : tonumber(Stack[i++], "-"); - for (; i < (int)SP; i++) { - n = tonumber(Stack[i], "-"); - s -= n; - } - v = number(s); - break; - case F_MUL: - s = 1; - for (i = saveSP + 1; i < (int)SP; i++) { - n = tonumber(Stack[i], "*"); - s *= n; - } - v = number(s); - break; - case F_DIV: - if (nargs < 1) - lerror("/: error: too few arguments\n"); - i = saveSP + 1; - s = (nargs == 1) ? 1 : tonumber(Stack[i++], "/"); - for (; i < (int)SP; i++) { - n = tonumber(Stack[i], "/"); - if (n == 0) - lerror("/: error: division by zero\n"); - s /= n; - } - v = number(s); - break; - case F_LT: - argcount("<", nargs, 2); - // this implements generic comparison for all atoms - // strange comparisons (for example with builtins) are resolved - // arbitrarily but consistently. - // ordering: number < builtin < symbol < cons - if (tag(Stack[SP - 2]) != tag(Stack[SP - 1])) { - v = (tag(Stack[SP - 2]) < tag(Stack[SP - 1]) ? T : NIL); - } else { - switch (tag(Stack[SP - 2])) { - case TAG_NUM: - v = - (numval(Stack[SP - 2]) < numval(Stack[SP - 1])) ? T : NIL; - break; - case TAG_SYM: - v = (strcmp(((symbol_t *)ptr(Stack[SP - 2]))->name, - ((symbol_t *)ptr(Stack[SP - 1]))->name) < 0) - ? T - : NIL; - break; - case TAG_BUILTIN: - v = - (intval(Stack[SP - 2]) < intval(Stack[SP - 1])) ? T : NIL; - break; - case TAG_CONS: - lerror("<: error: expected atom\n"); - } - } - break; - case F_NOT: - argcount("not", nargs, 1); - v = ((Stack[SP - 1] == NIL) ? T : NIL); - break; - case F_EVAL: - argcount("eval", nargs, 1); - v = Stack[SP - 1]; - if (tag(v) < 0x2) { - SP = saveSP; - return v; - } - if (tail) { - *penv = NIL; - envend = SP = (u_int32_t)(penv - &Stack[0]) + 1; - e = v; - goto eval_top; - } else { - PUSH(NIL); - v = eval_sexpr(v, &Stack[SP - 1], 1, SP); - } - break; - case F_PRINT: - for (i = saveSP + 1; i < (int)SP; i++) - print(stdout, v = Stack[i], 0); - fprintf(stdout, "\n"); - break; - case F_PRINC: - for (i = saveSP + 1; i < (int)SP; i++) - print(stdout, v = Stack[i], 1); - break; - case F_READ: - argcount("read", nargs, 0); - v = read_sexpr(stdin); - break; - case F_LOAD: - argcount("load", nargs, 1); - v = load_file(tosymbol(Stack[SP - 1], "load")->name); - break; - case F_EXIT: - exit(0); - break; - case F_ERROR: - for (i = saveSP + 1; i < (int)SP; i++) - print(stderr, Stack[i], 1); - lerror("\n"); - break; - case F_PROG1: - // return first arg - if (nargs < 1) - lerror("prog1: error: too few arguments\n"); - v = Stack[saveSP + 1]; - break; - case F_ASSOC: - argcount("assoc", nargs, 2); - v = assoc(Stack[SP - 2], Stack[SP - 1]); - break; - case F_APPLY: - argcount("apply", nargs, 2); - v = Stack[saveSP] = Stack[SP - 1]; // second arg is new arglist - f = Stack[SP - 2]; // first arg is new function - POPN(2); // pop apply's args - if (isbuiltin(f)) { - if (isspecial(f)) - lerror("apply: error: cannot apply special operator " - "%s\n", - builtin_names[intval(f)]); - // unpack arglist onto the stack - while (iscons(v)) { - PUSH(car_(v)); - v = cdr_(v); - } - goto apply_builtin; - } - noeval = 1; - goto apply_lambda; - } - SP = saveSP; - return v; - } else { - v = Stack[saveSP] = cdr_(Stack[saveSP]); - } -apply_lambda: - if (iscons(f)) { - headsym = car_(f); - // apply lambda or macro expression - PUSH(cdr(cdr_(f))); - PUSH(car_(cdr_(f))); - argsyms = &Stack[SP - 1]; - argenv = &Stack[SP]; // argument environment starts now - if (headsym == MACRO) - noeval = 1; - // else if (headsym != LAMBDA) - // lerror("apply: error: head must be lambda, macro, or label\n"); - // build a calling environment for the lambda - // the environment is the argument binds on top of the captured - // environment - while (iscons(v)) { - // bind args - if (!iscons(*argsyms)) { - if (*argsyms == NIL) - lerror("apply: error: too many arguments\n"); - break; - } - asym = car_(*argsyms); - if (asym == NIL || iscons(asym)) - lerror("apply: error: invalid formal argument\n"); - v = car_(v); - if (!noeval) { - v = eval(v); - } - PUSH(asym); - PUSH(v); - *argsyms = cdr_(*argsyms); - v = Stack[saveSP] = cdr_(Stack[saveSP]); - } - if (*argsyms != NIL) { - if (issymbol(*argsyms)) { - PUSH(*argsyms); - if (noeval) { - PUSH(Stack[saveSP]); - } else { - // this version uses collective allocation. about 7-10% - // faster for lists with > 2 elements, but uses more - // stack space - PUSH(NIL); - i = SP; - while (iscons(Stack[saveSP])) { - PUSH(eval(car_(Stack[saveSP]))); - Stack[saveSP] = cdr_(Stack[saveSP]); - } - nargs = SP - i; - if (nargs) { - Stack[i - 1] = cons_reserve(nargs); - c = (cons_t *)ptr(Stack[i - 1]); - for (; i < (int)SP; i++) { - c->car = Stack[i]; - c->cdr = tagptr(c + 1, TAG_CONS); - c++; - } - (c - 1)->cdr = NIL; - POPN(nargs); - } - } - } else if (iscons(*argsyms)) { - lerror("apply: error: too few arguments\n"); - } - } - noeval = 0; - lenv = &Stack[saveSP + 1]; - PUSH(cdr(*lenv)); // add cloenv to new environment - e = car_(Stack[saveSP + 1]); - // macro: evaluate expansion in the calling environment - if (headsym == MACRO) { - if (tag(e) < 0x2) - ; - else - e = eval_sexpr(e, argenv, 1, SP); - SP = saveSP; - if (tag(e) < 0x2) - return (e); - goto eval_top; - } else { - if (tag(e) < 0x2) { - SP = saveSP; - return (e); - } - if (tail) { - // ok to overwrite environment - nargs = (int)(&Stack[SP] - argenv); - for (i = 0; i < nargs; i++) - penv[i] = argenv[i]; - envend = SP = (u_int32_t)((penv + nargs) - &Stack[0]); - goto eval_top; - } else { - v = eval_sexpr(e, argenv, 1, SP); - SP = saveSP; - return v; - } - } - // not reached - } - type_error("apply", "function", f); - return NIL; -} - -// repl -// ----------------------------------------------------------------------- - -static char *infile = NULL; - -value_t toplevel_eval(value_t expr) -{ - value_t v; - u_int32_t saveSP = SP; - PUSH(NIL); - v = topeval(expr, &Stack[SP - 1]); - SP = saveSP; - return v; -} - -value_t load_file(char *fname) -{ - value_t e, v = NIL; - char *lastfile = infile; - FILE *f = fopen(fname, "r"); - infile = fname; - if (f == NULL) - lerror("file not found\n"); - while (1) { - e = read_sexpr(f); - if (feof(f)) - break; - v = toplevel_eval(e); - } - infile = lastfile; - fclose(f); - return v; -} - -int main(int argc, char *argv[]) -{ - value_t v; - - stack_bottom = ((char *)&v) - PROCESS_STACK_SIZE; - lisp_init(); - if (setjmp(toplevel)) { - SP = 0; - fprintf(stderr, "\n"); - if (infile) { - fprintf(stderr, "error loading file \"%s\"\n", infile); - infile = NULL; - } - goto repl; - } - load_file("system.lsp"); - if (argc > 1) { - load_file(argv[1]); - return 0; - } - printf("; _ \n"); - printf("; |_ _ _ |_ _ | . _ _ 2\n"); - printf("; | (-||||_(_)|__|_)|_)\n"); - printf(";-------------------|--------------------------------------------" - "--------------\n\n"); -repl: - while (1) { - printf("> "); - v = read_sexpr(stdin); - if (feof(stdin)) - break; - print(stdout, v = toplevel_eval(v), 0); - set(symbol("that"), v); - printf("\n\n"); - } - return 0; -} diff --git a/tiny/lispf.c b/tiny/lispf.c deleted file mode 100644 index 8e78c27..0000000 --- a/tiny/lispf.c +++ /dev/null @@ -1,1109 +0,0 @@ -/* - femtoLisp - - a minimal interpreter for a minimal lisp dialect - - this lisp dialect uses lexical scope and self-evaluating lambda. - it supports 30-bit integers, symbols, conses, and full macros. - it is case-sensitive. - it features a simple compacting copying garbage collector. - it uses a Scheme-style evaluation rule where any expression may appear in - head position as long as it evaluates to a function. - it uses Scheme-style varargs (dotted formal argument lists) - lambdas can have only 1 body expression; use (progn ...) for multiple - expressions. this is due to the closure representation - (lambda args body . env) - - lispf is a fork that provides an #ifdef FLOAT option to use single-precision - floating point numbers instead of integers, albeit with even less precision - than usual---only 21 significant mantissa bits! - - it is now also being used to test a tail-recursive evaluator. - - by Jeff Bezanson - Public Domain -*/ - -#include -#include -#include -#include -#include -#include -#include - -typedef u_int32_t value_t; -#ifdef FLOAT -typedef float number_t; -#else -typedef int32_t number_t; -#endif - -typedef struct { - value_t car; - value_t cdr; -} cons_t; - -typedef struct _symbol_t { - value_t binding; // global value binding - value_t constant; // constant binding (used only for builtins) - struct _symbol_t *left; - struct _symbol_t *right; - char name[1]; -} symbol_t; - -#define TAG_NUM 0x0 -#define TAG_BUILTIN 0x1 -#define TAG_SYM 0x2 -#define TAG_CONS 0x3 -#define UNBOUND ((value_t)TAG_SYM) // an invalid symbol pointer -#define tag(x) ((x)&0x3) -#define ptr(x) ((void *)((x) & (~(value_t)0x3))) -#define tagptr(p, t) (((value_t)(p)) | (t)) -#ifdef FLOAT -#define number(x) ((*(value_t *)&(x)) & ~0x3) -#define numval(x) (*(number_t *)&(x)) -#define NUM_FORMAT "%f" -extern float strtof(const char *nptr, char **endptr); -#define strtonum(s, e) strtof(s, e) -#else -#define number(x) ((value_t)((x) << 2)) -#define numval(x) (((number_t)(x)) >> 2) -#define NUM_FORMAT "%d" -#define strtonum(s, e) strtol(s, e, 10) -#endif -#define intval(x) (((int)(x)) >> 2) -#define builtin(n) tagptr((((int)n) << 2), TAG_BUILTIN) -#define iscons(x) (tag(x) == TAG_CONS) -#define issymbol(x) (tag(x) == TAG_SYM) -#define isnumber(x) (tag(x) == TAG_NUM) -#define isbuiltin(x) (tag(x) == TAG_BUILTIN) -// functions ending in _ are unsafe, faster versions -#define car_(v) (((cons_t *)ptr(v))->car) -#define cdr_(v) (((cons_t *)ptr(v))->cdr) -#define car(v) (tocons((v), "car")->car) -#define cdr(v) (tocons((v), "cdr")->cdr) -#define set(s, v) (((symbol_t *)ptr(s))->binding = (v)) -#define setc(s, v) (((symbol_t *)ptr(s))->constant = (v)) - -enum { - // special forms - F_QUOTE = 0, - F_COND, - F_IF, - F_AND, - F_OR, - F_WHILE, - F_LAMBDA, - F_MACRO, - F_LABEL, - F_PROGN, - // functions - F_EQ, - F_ATOM, - F_CONS, - F_CAR, - F_CDR, - F_READ, - F_EVAL, - F_PRINT, - F_SET, - F_NOT, - F_LOAD, - F_SYMBOLP, - F_NUMBERP, - F_ADD, - F_SUB, - F_MUL, - F_DIV, - F_LT, - F_PROG1, - F_APPLY, - F_RPLACA, - F_RPLACD, - F_BOUNDP, - N_BUILTINS -}; -#define isspecial(v) (intval(v) <= (int)F_PROGN) - -static char *builtin_names[] = { - "quote", "cond", "if", "and", "or", "while", "lambda", - "macro", "label", "progn", "eq", "atom", "cons", "car", - "cdr", "read", "eval", "print", "set", "not", "load", - "symbolp", "numberp", "+", "-", "*", "/", "<", - "prog1", "apply", "rplaca", "rplacd", "boundp" -}; - -static char *stack_bottom; -#define PROCESS_STACK_SIZE (2 * 1024 * 1024) -#define N_STACK 49152 -static value_t Stack[N_STACK]; -static u_int32_t SP = 0; -#define PUSH(v) (Stack[SP++] = (v)) -#define POP() (Stack[--SP]) -#define POPN(n) (SP -= (n)) - -value_t NIL, T, LAMBDA, MACRO, LABEL, QUOTE; - -value_t read_sexpr(FILE *f); -void print(FILE *f, value_t v); -value_t eval_sexpr(value_t e, value_t *penv); -value_t load_file(char *fname); - -// error utilities -// ------------------------------------------------------------ - -jmp_buf toplevel; - -void lerror(char *format, ...) -{ - va_list args; - va_start(args, format); - vfprintf(stderr, format, args); - va_end(args); - longjmp(toplevel, 1); -} - -void type_error(char *fname, char *expected, value_t got) -{ - fprintf(stderr, "%s: error: expected %s, got ", fname, expected); - print(stderr, got); - lerror("\n"); -} - -// safe cast operators -// -------------------------------------------------------- - -#define SAFECAST_OP(type, ctype, cnvt) \ - ctype to##type(value_t v, char *fname) \ - { \ - if (is##type(v)) \ - return (ctype)cnvt(v); \ - type_error(fname, #type, v); \ - return (ctype)0; \ - } -SAFECAST_OP(cons, cons_t *, ptr) -SAFECAST_OP(symbol, symbol_t *, ptr) -SAFECAST_OP(number, number_t, numval) - -// symbol table -// --------------------------------------------------------------- - -static symbol_t *symtab = NULL; - -static symbol_t *mk_symbol(char *str) -{ - symbol_t *sym; - - sym = (symbol_t *)malloc(sizeof(symbol_t) + strlen(str)); - sym->left = sym->right = NULL; - sym->constant = sym->binding = UNBOUND; - strcpy(&sym->name[0], str); - return sym; -} - -static symbol_t **symtab_lookup(symbol_t **ptree, char *str) -{ - int x; - - while (*ptree != NULL) { - x = strcmp(str, (*ptree)->name); - if (x == 0) - return ptree; - if (x < 0) - ptree = &(*ptree)->left; - else - ptree = &(*ptree)->right; - } - return ptree; -} - -value_t symbol(char *str) -{ - symbol_t **pnode; - - pnode = symtab_lookup(&symtab, str); - if (*pnode == NULL) - *pnode = mk_symbol(str); - return tagptr(*pnode, TAG_SYM); -} - -// initialization -// ------------------------------------------------------------- - -static unsigned char *fromspace; -static unsigned char *tospace; -static unsigned char *curheap; -static unsigned char *lim; -static u_int32_t heapsize = 64 * 1024; // bytes - -void lisp_init(void) -{ - int i; - - fromspace = malloc(heapsize); - tospace = malloc(heapsize); - curheap = fromspace; - lim = curheap + heapsize - sizeof(cons_t); - - NIL = symbol("nil"); - setc(NIL, NIL); - T = symbol("t"); - setc(T, T); - LAMBDA = symbol("lambda"); - MACRO = symbol("macro"); - LABEL = symbol("label"); - QUOTE = symbol("quote"); - for (i = 0; i < (int)N_BUILTINS; i++) - setc(symbol(builtin_names[i]), builtin(i)); - setc(symbol("princ"), builtin(F_PRINT)); -} - -// conses -// --------------------------------------------------------------------- - -void gc(void); - -static value_t mk_cons(void) -{ - cons_t *c; - - if (curheap > lim) - gc(); - c = (cons_t *)curheap; - curheap += sizeof(cons_t); - return tagptr(c, TAG_CONS); -} - -static value_t cons_(value_t *pcar, value_t *pcdr) -{ - value_t c = mk_cons(); - car_(c) = *pcar; - cdr_(c) = *pcdr; - return c; -} - -value_t *cons(value_t *pcar, value_t *pcdr) -{ - value_t c = mk_cons(); - car_(c) = *pcar; - cdr_(c) = *pcdr; - PUSH(c); - return &Stack[SP - 1]; -} - -// collector -// ------------------------------------------------------------------ - -static value_t relocate(value_t v) -{ - value_t a, d, nc; - - if (!iscons(v)) - return v; - if (car_(v) == UNBOUND) - return cdr_(v); - nc = mk_cons(); - car_(nc) = NIL; - a = car_(v); - d = cdr_(v); - car_(v) = UNBOUND; - cdr_(v) = nc; - car_(nc) = relocate(a); - cdr_(nc) = relocate(d); - return nc; -} - -static void trace_globals(symbol_t *root) -{ - while (root != NULL) { - root->binding = relocate(root->binding); - trace_globals(root->left); - root = root->right; - } -} - -void gc(void) -{ - static int grew = 0; - unsigned char *temp; - u_int32_t i; - - curheap = tospace; - lim = curheap + heapsize - sizeof(cons_t); - - for (i = 0; i < SP; i++) - Stack[i] = relocate(Stack[i]); - trace_globals(symtab); -#ifdef VERBOSEGC - printf("gc found %d/%d live conses\n", (curheap - tospace) / 8, - heapsize / 8); -#endif - temp = tospace; - tospace = fromspace; - fromspace = temp; - - // if we're using > 80% of the space, resize tospace so we have - // more space to fill next time. if we grew tospace last time, - // grow the other half of the heap this time to catch up. - if (grew || ((lim - curheap) < (int)(heapsize / 5))) { - temp = realloc(tospace, grew ? heapsize : heapsize * 2); - if (temp == NULL) - lerror("out of memory\n"); - tospace = temp; - if (!grew) - heapsize *= 2; - grew = !grew; - } - if (curheap > lim) // all data was live - gc(); -} - -// read -// ----------------------------------------------------------------------- - -enum { TOK_NONE, TOK_OPEN, TOK_CLOSE, TOK_DOT, TOK_QUOTE, TOK_SYM, TOK_NUM }; - -static int symchar(char c) -{ - static char *special = "()';\\|"; - return (!isspace(c) && !strchr(special, c)); -} - -static u_int32_t toktype = TOK_NONE; -static value_t tokval; -static char buf[256]; - -static char nextchar(FILE *f) -{ - char c; - int ch; - - do { - ch = fgetc(f); - if (ch == EOF) - return 0; - c = (char)ch; - if (c == ';') { - // single-line comment - do { - ch = fgetc(f); - if (ch == EOF) - return 0; - } while ((char)ch != '\n'); - c = (char)ch; - } - } while (isspace(c)); - return c; -} - -static void take(void) { toktype = TOK_NONE; } - -static void accumchar(char c, int *pi) -{ - buf[(*pi)++] = c; - if (*pi >= (int)(sizeof(buf) - 1)) - lerror("read: error: token too long\n"); -} - -static int read_token(FILE *f, char c) -{ - int i = 0, ch, escaped = 0; - - ungetc(c, f); - while (1) { - ch = fgetc(f); - if (ch == EOF) - goto terminate; - c = (char)ch; - if (c == '|') { - escaped = !escaped; - } else if (c == '\\') { - ch = fgetc(f); - if (ch == EOF) - goto terminate; - accumchar((char)ch, &i); - } else if (!escaped && !symchar(c)) { - break; - } else { - accumchar(c, &i); - } - } - ungetc(c, f); -terminate: - buf[i++] = '\0'; - return i; -} - -static u_int32_t peek(FILE *f) -{ - char c, *end; - number_t x; - - if (toktype != TOK_NONE) - return toktype; - c = nextchar(f); - if (feof(f)) - return TOK_NONE; - if (c == '(') { - toktype = TOK_OPEN; - } else if (c == ')') { - toktype = TOK_CLOSE; - } else if (c == '\'') { - toktype = TOK_QUOTE; - } else if (isdigit(c) || c == '-') { - read_token(f, c); - if (buf[0] == '-' && !isdigit(buf[1])) { - toktype = TOK_SYM; - tokval = symbol(buf); - } else { - x = strtonum(buf, &end); - if (*end != '\0') - lerror("read: error: invalid constant\n"); - toktype = TOK_NUM; - tokval = number(x); - } - } else { - read_token(f, c); - if (!strcmp(buf, ".")) { - toktype = TOK_DOT; - } else { - toktype = TOK_SYM; - tokval = symbol(buf); - } - } - return toktype; -} - -// build a list of conses. this is complicated by the fact that all conses -// can move whenever a new cons is allocated. we have to refer to every cons -// through a handle to a relocatable pointer (i.e. a pointer on the stack). -static void read_list(FILE *f, value_t *pval) -{ - value_t c, *pc; - u_int32_t t; - - PUSH(NIL); - pc = &Stack[SP - 1]; // to keep track of current cons cell - t = peek(f); - while (t != TOK_CLOSE) { - if (feof(f)) - lerror("read: error: unexpected end of input\n"); - c = mk_cons(); - car_(c) = cdr_(c) = NIL; - if (iscons(*pc)) - cdr_(*pc) = c; - else - *pval = c; - *pc = c; - c = read_sexpr(f); // must be on separate lines due to undefined - car_(*pc) = c; // evaluation order - - t = peek(f); - if (t == TOK_DOT) { - take(); - c = read_sexpr(f); - cdr_(*pc) = c; - t = peek(f); - if (feof(f)) - lerror("read: error: unexpected end of input\n"); - if (t != TOK_CLOSE) - lerror("read: error: expected ')'\n"); - } - } - take(); - POP(); -} - -value_t read_sexpr(FILE *f) -{ - value_t v; - - switch (peek(f)) { - case TOK_CLOSE: - take(); - lerror("read: error: unexpected ')'\n"); - case TOK_DOT: - take(); - lerror("read: error: unexpected '.'\n"); - case TOK_SYM: - case TOK_NUM: - take(); - return tokval; - case TOK_QUOTE: - take(); - v = read_sexpr(f); - PUSH(v); - v = cons_("E, cons(&Stack[SP - 1], &NIL)); - POPN(2); - return v; - case TOK_OPEN: - take(); - PUSH(NIL); - read_list(f, &Stack[SP - 1]); - return POP(); - } - return NIL; -} - -// print -// ---------------------------------------------------------------------- - -void print(FILE *f, value_t v) -{ - value_t cd; - - switch (tag(v)) { - case TAG_NUM: - fprintf(f, NUM_FORMAT, numval(v)); - break; - case TAG_SYM: - fprintf(f, "%s", ((symbol_t *)ptr(v))->name); - break; - case TAG_BUILTIN: - fprintf(f, "#", builtin_names[intval(v)]); - break; - case TAG_CONS: - fprintf(f, "("); - while (1) { - print(f, car_(v)); - cd = cdr_(v); - if (!iscons(cd)) { - if (cd != NIL) { - fprintf(f, " . "); - print(f, cd); - } - fprintf(f, ")"); - break; - } - fprintf(f, " "); - v = cd; - } - break; - } -} - -// eval -// ----------------------------------------------------------------------- - -static inline void argcount(char *fname, int nargs, int c) -{ - if (nargs != c) - lerror("%s: error: too %s arguments\n", fname, - nargs < c ? "few" : "many"); -} - -#define eval(e, penv) ((tag(e) < 0x2) ? (e) : eval_sexpr((e), penv)) -#define tail_eval(xpr, env) \ - do { \ - SP = saveSP; \ - if (tag(xpr) < 0x2) { \ - return (xpr); \ - } else { \ - e = (xpr); \ - *penv = (env); \ - goto eval_top; \ - } \ - } while (0) - -value_t eval_sexpr(value_t e, value_t *penv) -{ - value_t f, v, bind, headsym, asym, labl = 0, *pv, *argsyms, *body, *lenv; - value_t *rest; - cons_t *c; - symbol_t *sym; - u_int32_t saveSP; - int i, nargs, noeval = 0; - number_t s, n; - -eval_top: - if (issymbol(e)) { - sym = (symbol_t *)ptr(e); - if (sym->constant != UNBOUND) - return sym->constant; - v = *penv; - while (iscons(v)) { - bind = car_(v); - if (iscons(bind) && car_(bind) == e) - return cdr_(bind); - v = cdr_(v); - } - if ((v = sym->binding) == UNBOUND) - lerror("eval: error: variable %s has no value\n", sym->name); - return v; - } - if ((unsigned)(char *)&nargs < (unsigned)stack_bottom || - SP >= (N_STACK - 100)) - lerror("eval: error: stack overflow\n"); - saveSP = SP; - PUSH(e); - PUSH(*penv); - f = eval(car_(e), penv); - *penv = Stack[saveSP + 1]; - if (isbuiltin(f)) { - // handle builtin function - if (!isspecial(f)) { - // evaluate argument list, placing arguments on stack - v = Stack[saveSP] = cdr_(Stack[saveSP]); - while (iscons(v)) { - v = eval(car_(v), penv); - *penv = Stack[saveSP + 1]; - PUSH(v); - v = Stack[saveSP] = cdr_(Stack[saveSP]); - } - } - apply_builtin: - nargs = SP - saveSP - 2; - switch (intval(f)) { - // special forms - case F_QUOTE: - v = cdr_(Stack[saveSP]); - if (!iscons(v)) - lerror("quote: error: expected argument\n"); - v = car_(v); - break; - case F_MACRO: - case F_LAMBDA: - v = Stack[saveSP]; - if (*penv != NIL) { - // build a closure (lambda args body . env) - v = cdr_(v); - PUSH(car(v)); - argsyms = &Stack[SP - 1]; - PUSH(car(cdr_(v))); - body = &Stack[SP - 1]; - v = cons_(intval(f) == F_LAMBDA ? &LAMBDA : &MACRO, - cons(argsyms, cons(body, penv))); - } - break; - case F_LABEL: - v = Stack[saveSP]; - if (*penv != NIL) { - v = cdr_(v); - PUSH(car(v)); // name - pv = &Stack[SP - 1]; - PUSH(car(cdr_(v))); // function - body = &Stack[SP - 1]; - *body = eval(*body, penv); // evaluate lambda - v = cons_(&LABEL, cons(pv, cons(body, &NIL))); - } - break; - case F_IF: - v = car(cdr_(Stack[saveSP])); - if (eval(v, penv) != NIL) - v = car(cdr_(cdr_(Stack[saveSP]))); - else - v = car(cdr(cdr_(cdr_(Stack[saveSP])))); - tail_eval(v, Stack[saveSP + 1]); - break; - case F_COND: - Stack[saveSP] = cdr_(Stack[saveSP]); - pv = &Stack[saveSP]; - v = NIL; - while (iscons(*pv)) { - c = tocons(car_(*pv), "cond"); - v = eval(c->car, penv); - *penv = Stack[saveSP + 1]; - if (v != NIL) { - *pv = cdr_(car_(*pv)); - // evaluate body forms - if (iscons(*pv)) { - while (iscons(cdr_(*pv))) { - v = eval(car_(*pv), penv); - *penv = Stack[saveSP + 1]; - *pv = cdr_(*pv); - } - tail_eval(car_(*pv), *penv); - } - break; - } - *pv = cdr_(*pv); - } - break; - case F_AND: - Stack[saveSP] = cdr_(Stack[saveSP]); - pv = &Stack[saveSP]; - v = T; - if (iscons(*pv)) { - while (iscons(cdr_(*pv))) { - if ((v = eval(car_(*pv), penv)) == NIL) { - SP = saveSP; - return NIL; - } - *penv = Stack[saveSP + 1]; - *pv = cdr_(*pv); - } - tail_eval(car_(*pv), *penv); - } - break; - case F_OR: - Stack[saveSP] = cdr_(Stack[saveSP]); - pv = &Stack[saveSP]; - v = NIL; - if (iscons(*pv)) { - while (iscons(cdr_(*pv))) { - if ((v = eval(car_(*pv), penv)) != NIL) { - SP = saveSP; - return v; - } - *penv = Stack[saveSP + 1]; - *pv = cdr_(*pv); - } - tail_eval(car_(*pv), *penv); - } - break; - case F_WHILE: - PUSH(car(cdr(cdr_(Stack[saveSP])))); - body = &Stack[SP - 1]; - Stack[saveSP] = car_(cdr_(Stack[saveSP])); - value_t *cond = &Stack[saveSP]; - PUSH(NIL); - pv = &Stack[SP - 1]; - while (eval(*cond, penv) != NIL) { - *penv = Stack[saveSP + 1]; - *pv = eval(*body, penv); - *penv = Stack[saveSP + 1]; - } - v = *pv; - break; - case F_PROGN: - // return last arg - Stack[saveSP] = cdr_(Stack[saveSP]); - pv = &Stack[saveSP]; - v = NIL; - if (iscons(*pv)) { - while (iscons(cdr_(*pv))) { - v = eval(car_(*pv), penv); - *penv = Stack[saveSP + 1]; - *pv = cdr_(*pv); - } - tail_eval(car_(*pv), *penv); - } - break; - - // ordinary functions - case F_SET: - argcount("set", nargs, 2); - e = Stack[SP - 2]; - v = *penv; - while (iscons(v)) { - bind = car_(v); - if (iscons(bind) && car_(bind) == e) { - cdr_(bind) = (v = Stack[SP - 1]); - SP = saveSP; - return v; - } - v = cdr_(v); - } - tosymbol(e, "set")->binding = (v = Stack[SP - 1]); - break; - case F_BOUNDP: - argcount("boundp", nargs, 1); - if (tosymbol(Stack[SP - 1], "boundp")->binding == UNBOUND) - v = NIL; - else - v = T; - break; - case F_EQ: - argcount("eq", nargs, 2); - v = ((Stack[SP - 2] == Stack[SP - 1]) ? T : NIL); - break; - case F_CONS: - argcount("cons", nargs, 2); - v = mk_cons(); - car_(v) = Stack[SP - 2]; - cdr_(v) = Stack[SP - 1]; - break; - case F_CAR: - argcount("car", nargs, 1); - v = car(Stack[SP - 1]); - break; - case F_CDR: - argcount("cdr", nargs, 1); - v = cdr(Stack[SP - 1]); - break; - case F_RPLACA: - argcount("rplaca", nargs, 2); - car(v = Stack[SP - 2]) = Stack[SP - 1]; - break; - case F_RPLACD: - argcount("rplacd", nargs, 2); - cdr(v = Stack[SP - 2]) = Stack[SP - 1]; - break; - case F_ATOM: - argcount("atom", nargs, 1); - v = ((!iscons(Stack[SP - 1])) ? T : NIL); - break; - case F_SYMBOLP: - argcount("symbolp", nargs, 1); - v = ((issymbol(Stack[SP - 1])) ? T : NIL); - break; - case F_NUMBERP: - argcount("numberp", nargs, 1); - v = ((isnumber(Stack[SP - 1])) ? T : NIL); - break; - case F_ADD: - s = 0; - for (i = saveSP + 2; i < (int)SP; i++) { - n = tonumber(Stack[i], "+"); - s += n; - } - v = number(s); - break; - case F_SUB: - if (nargs < 1) - lerror("-: error: too few arguments\n"); - i = saveSP + 2; - s = (nargs == 1) ? 0 : tonumber(Stack[i++], "-"); - for (; i < (int)SP; i++) { - n = tonumber(Stack[i], "-"); - s -= n; - } - v = number(s); - break; - case F_MUL: - s = 1; - for (i = saveSP + 2; i < (int)SP; i++) { - n = tonumber(Stack[i], "*"); - s *= n; - } - v = number(s); - break; - case F_DIV: - if (nargs < 1) - lerror("/: error: too few arguments\n"); - i = saveSP + 2; - s = (nargs == 1) ? 1 : tonumber(Stack[i++], "/"); - for (; i < (int)SP; i++) { - n = tonumber(Stack[i], "/"); - if (n == 0) - lerror("/: error: division by zero\n"); - s /= n; - } - v = number(s); - break; - case F_LT: - argcount("<", nargs, 2); - if (tonumber(Stack[SP - 2], "<") < tonumber(Stack[SP - 1], "<")) - v = T; - else - v = NIL; - break; - case F_NOT: - argcount("not", nargs, 1); - v = ((Stack[SP - 1] == NIL) ? T : NIL); - break; - case F_EVAL: - argcount("eval", nargs, 1); - v = Stack[SP - 1]; - tail_eval(v, NIL); - break; - case F_PRINT: - for (i = saveSP + 2; i < (int)SP; i++) - print(stdout, v = Stack[i]); - break; - case F_READ: - argcount("read", nargs, 0); - v = read_sexpr(stdin); - break; - case F_LOAD: - argcount("load", nargs, 1); - v = load_file(tosymbol(Stack[SP - 1], "load")->name); - break; - case F_PROG1: - // return first arg - if (nargs < 1) - lerror("prog1: error: too few arguments\n"); - v = Stack[saveSP + 2]; - break; - case F_APPLY: - argcount("apply", nargs, 2); - v = Stack[saveSP] = Stack[SP - 1]; // second arg is new arglist - f = Stack[SP - 2]; // first arg is new function - POPN(2); // pop apply's args - if (isbuiltin(f)) { - if (isspecial(f)) - lerror("apply: error: cannot apply special operator " - "%s\n", - builtin_names[intval(f)]); - // unpack arglist onto the stack - while (iscons(v)) { - PUSH(car_(v)); - v = cdr_(v); - } - goto apply_builtin; - } - noeval = 1; - goto apply_lambda; - } - SP = saveSP; - return v; - } else { - v = Stack[saveSP] = cdr_(Stack[saveSP]); - } -apply_lambda: - if (iscons(f)) { - headsym = car_(f); - if (headsym == LABEL) { - // (label name (lambda ...)) behaves the same as the lambda - // alone, except with name bound to the whole label expression - labl = f; - f = car(cdr(cdr_(labl))); - headsym = car(f); - } - // apply lambda or macro expression - PUSH(cdr(cdr(cdr_(f)))); - lenv = &Stack[SP - 1]; - PUSH(car_(cdr_(f))); - argsyms = &Stack[SP - 1]; - PUSH(car_(cdr_(cdr_(f)))); - body = &Stack[SP - 1]; - if (labl) { - // add label binding to environment - PUSH(labl); - PUSH(car_(cdr_(labl))); - *lenv = cons_(cons(&Stack[SP - 1], &Stack[SP - 2]), lenv); - POPN(3); - v = Stack[saveSP]; // refetch arglist - } - if (headsym == MACRO) - noeval = 1; - else if (headsym != LAMBDA) - lerror("apply: error: head must be lambda, macro, or label\n"); - // build a calling environment for the lambda - // the environment is the argument binds on top of the captured - // environment - while (iscons(v)) { - // bind args - if (!iscons(*argsyms)) { - if (*argsyms == NIL) - lerror("apply: error: too many arguments\n"); - break; - } - asym = car_(*argsyms); - if (!issymbol(asym)) - lerror("apply: error: formal argument not a symbol\n"); - v = car_(v); - if (!noeval) { - v = eval(v, penv); - *penv = Stack[saveSP + 1]; - } - PUSH(v); - *lenv = cons_(cons(&asym, &Stack[SP - 1]), lenv); - POPN(2); - *argsyms = cdr_(*argsyms); - v = Stack[saveSP] = cdr_(Stack[saveSP]); - } - if (*argsyms != NIL) { - if (issymbol(*argsyms)) { - if (noeval) { - *lenv = cons_(cons(argsyms, &Stack[saveSP]), lenv); - } else { - PUSH(NIL); - PUSH(NIL); - rest = &Stack[SP - 1]; - // build list of rest arguments - // we have to build it forwards, which is tricky - while (iscons(v)) { - v = eval(car_(v), penv); - *penv = Stack[saveSP + 1]; - PUSH(v); - v = cons_(&Stack[SP - 1], &NIL); - POP(); - if (iscons(*rest)) - cdr_(*rest) = v; - else - Stack[SP - 2] = v; - *rest = v; - v = Stack[saveSP] = cdr_(Stack[saveSP]); - } - *lenv = cons_(cons(argsyms, &Stack[SP - 2]), lenv); - } - } else if (iscons(*argsyms)) { - lerror("apply: error: too few arguments\n"); - } - } - noeval = 0; - // macro: evaluate expansion in the calling environment - if (headsym == MACRO) { - SP = saveSP; - PUSH(*lenv); - lenv = &Stack[SP - 1]; - v = eval(*body, lenv); - tail_eval(v, *penv); - } else { - tail_eval(*body, *lenv); - } - // not reached - } - type_error("apply", "function", f); - return NIL; -} - -// repl -// ----------------------------------------------------------------------- - -static char *infile = NULL; - -value_t toplevel_eval(value_t expr) -{ - value_t v; - PUSH(NIL); - v = eval(expr, &Stack[SP - 1]); - POP(); - return v; -} - -value_t load_file(char *fname) -{ - value_t e, v = NIL; - char *lastfile = infile; - FILE *f = fopen(fname, "r"); - infile = fname; - if (f == NULL) - lerror("file not found\n"); - while (1) { - e = read_sexpr(f); - if (feof(f)) - break; - v = toplevel_eval(e); - } - infile = lastfile; - fclose(f); - return v; -} - -int main(int argc, char *argv[]) -{ - value_t v; - - stack_bottom = ((char *)&v) - PROCESS_STACK_SIZE; - lisp_init(); - if (setjmp(toplevel)) { - SP = 0; - fprintf(stderr, "\n"); - if (infile) { - fprintf(stderr, "error loading file \"%s\"\n", infile); - infile = NULL; - } - goto repl; - } - load_file("system.lsp"); - if (argc > 1) { - load_file(argv[1]); - return 0; - } - printf("Welcome to femtoLisp " - "----------------------------------------------------------\n"); -repl: - while (1) { - printf("> "); - v = read_sexpr(stdin); - if (feof(stdin)) - break; - print(stdout, v = toplevel_eval(v)); - set(symbol("that"), v); - printf("\n\n"); - } - return 0; -} diff --git a/tiny/system.lsp b/tiny/system.lsp deleted file mode 100644 index 4eba805..0000000 --- a/tiny/system.lsp +++ /dev/null @@ -1,426 +0,0 @@ -; femtoLisp standard library -; by Jeff Bezanson -; Public Domain - -(set 'list (lambda args args)) - -(set 'setq (macro (name val) - (list set (list quote name) val))) - -(setq sp '| |) -(setq nl '| -|) - -; convert a sequence of body statements to a single expression. -; this allows define, defun, defmacro, let, etc. to contain multiple -; body expressions as in Common Lisp. -(setq f-body (lambda (e) - (cond ((atom e) e) - ((eq (cdr e) ()) (car e)) - (t (cons progn e))))) - -(setq defmacro - (macro (name args . body) - (list 'setq name (list 'macro args (f-body body))))) - -; support both CL defun and Scheme-style define -(defmacro defun (name args . body) - (list 'setq name (list 'lambda args (f-body body)))) - -(defmacro define (name . body) - (if (symbolp name) - (list 'setq name (car body)) - (cons 'defun (cons (car name) (cons (cdr name) body))))) - -(defun identity (x) x) -(setq null not) -(defun consp (x) (not (atom x))) - -(defun map (f lst) - (if (atom lst) lst - (cons (f (car lst)) (map f (cdr lst))))) - -(defmacro let (binds . body) - (cons (list 'lambda (map car binds) (f-body body)) - (map cadr binds))) - -(defun nconc lsts - (cond ((null lsts) ()) - ((null (cdr lsts)) (car lsts)) - (t ((lambda (l d) (if (null l) d - (prog1 l - (while (consp (cdr l)) (set 'l (cdr l))) - (rplacd l d)))) - (car lsts) (apply nconc (cdr lsts)))))) - -(defun append lsts - (cond ((null lsts) ()) - ((null (cdr lsts)) (car lsts)) - (t ((label append2 (lambda (l d) - (if (null l) d - (cons (car l) - (append2 (cdr l) d))))) - (car lsts) (apply append (cdr lsts)))))) - -(defun member (item lst) - (cond ((atom lst) ()) - ((eq (car lst) item) lst) - (t (member item (cdr lst))))) - -(defun macrop (e) (and (consp e) (eq (car e) 'macro) e)) -(defun macrocallp (e) (and (symbolp (car e)) - (boundp (car e)) - (macrop (eval (car e))))) -(defun macroapply (m args) (apply (cons 'lambda (cdr m)) args)) - -(defun macroexpand-1 (e) - (if (atom e) e - (let ((f (macrocallp e))) - (if f (macroapply f (cdr e)) - e)))) - -; convert to proper list, i.e. remove "dots", and append -(defun append.2 (l tail) - (cond ((null l) tail) - ((atom l) (cons l tail)) - (t (cons (car l) (append.2 (cdr l) tail))))) - -(defun macroexpand (e) - ((label mexpand - (lambda (e env f) - (progn - (while (and (consp e) - (not (member (car e) env)) - (set 'f (macrocallp e))) - (set 'e (macroapply f (cdr e)))) - (if (and (consp e) - (not (or (eq (car e) 'quote) - (eq (car e) quote)))) - (let ((newenv - (if (and (or (eq (car e) 'lambda) (eq (car e) 'macro)) - (consp (cdr e))) - (append.2 (cadr e) env) - env))) - (map (lambda (x) (mexpand x newenv nil)) e)) - e)))) - e nil nil)) - -; uncomment this to macroexpand functions at definition time. -; makes typical code ~25% faster, but only works for defun expressions -; at the top level. -;(defmacro defun (name args . body) -; (list 'setq name (list 'lambda args (macroexpand (f-body body))))) - -; same thing for macros. enabled by default because macros are usually -; defined at the top level. -(defmacro defmacro (name args . body) - (list 'setq name (list 'macro args (macroexpand (f-body body))))) - -(setq = eq) -(setq eql eq) -(define (/= a b) (not (eq a b))) -(define != /=) -(define (> a b) (< b a)) -(define (<= a b) (not (< b a))) -(define (>= a b) (not (< a b))) -(define (mod x y) (- x (* (/ x y) y))) -(define (abs x) (if (< x 0) (- x) x)) -(define (truncate x) x) -(setq K prog1) ; K combinator ;) -(define (funcall f . args) (apply f args)) -(define (symbol-function sym) (eval sym)) -(define (symbol-value sym) (eval sym)) - -(define (caar x) (car (car x))) -(define (cadr x) (car (cdr x))) -(define (cdar x) (cdr (car x))) -(define (cddr x) (cdr (cdr x))) -(define (caaar x) (car (car (car x)))) -(define (caadr x) (car (car (cdr x)))) -(define (cadar x) (car (cdr (car x)))) -(define (caddr x) (car (cdr (cdr x)))) -(define (cdaar x) (cdr (car (car x)))) -(define (cdadr x) (cdr (car (cdr x)))) -(define (cddar x) (cdr (cdr (car x)))) -(define (cdddr x) (cdr (cdr (cdr x)))) - -(define (equal a b) - (if (and (consp a) (consp b)) - (and (equal (car a) (car b)) - (equal (cdr a) (cdr b))) - (eq a b))) - -; compare imposes an ordering on all values. yields -1 for ab. lists are compared up to the first -; point of difference. -(defun compare (a b) - (cond ((eq a b) 0) - ((or (atom a) (atom b)) (if (< a b) -1 1)) - (t (let ((c (compare (car a) (car b)))) - (if (not (eq c 0)) - c - (compare (cdr a) (cdr b))))))) - -(defun every (pred lst) - (or (atom lst) - (and (pred (car lst)) - (every pred (cdr lst))))) - -(defun any (pred lst) - (and (consp lst) - (or (pred (car lst)) - (any pred (cdr lst))))) - -(defun listp (a) (or (eq a ()) (consp a))) - -(defun length (l) - (if (null l) 0 - (+ 1 (length (cdr l))))) - -(defun nthcdr (n lst) - (if (<= n 0) lst - (nthcdr (- n 1) (cdr lst)))) - -(defun list-ref (lst n) - (car (nthcdr n lst))) - -(defun list* l - (if (atom (cdr l)) - (car l) - (cons (car l) (apply list* (cdr l))))) - -(defun nlist* l - (if (atom (cdr l)) - (car l) - (rplacd l (apply nlist* (cdr l))))) - -(defun lastcdr (l) - (if (atom l) l - (lastcdr (cdr l)))) - -(defun last (l) - (cond ((atom l) l) - ((atom (cdr l)) l) - (t (last (cdr l))))) - -(defun map! (f lst) - (prog1 lst - (while (consp lst) - (rplaca lst (f (car lst))) - (set 'lst (cdr lst))))) - -(defun mapcar (f . lsts) - ((label mapcar- - (lambda (lsts) - (cond ((null lsts) (f)) - ((atom (car lsts)) (car lsts)) - (t (cons (apply f (map car lsts)) - (mapcar- (map cdr lsts))))))) - lsts)) - -(defun transpose (M) (apply mapcar (cons list M))) - -(defun filter (pred lst) - (cond ((null lst) ()) - ((not (pred (car lst))) (filter pred (cdr lst))) - (t (cons (car lst) (filter pred (cdr lst)))))) - -(define (foldr f zero lst) - (if (null lst) zero - (f (car lst) (foldr f zero (cdr lst))))) - -(define (foldl f zero lst) - (if (null lst) zero - (foldl f (f (car lst) zero) (cdr lst)))) - -(define (reverse lst) (foldl cons nil lst)) - -(define (reduce0 f zero lst) - (if (null lst) zero - (reduce0 f (f zero (car lst)) (cdr lst)))) - -(defun reduce (f lst) - (reduce0 f (car lst) (cdr lst))) - -(define (copy-list l) (map identity l)) -(define (copy-tree l) - (if (atom l) l - (cons (copy-tree (car l)) - (copy-tree (cdr l))))) - -(define (assoc item lst) - (cond ((atom lst) ()) - ((eq (caar lst) item) (car lst)) - (t (assoc item (cdr lst))))) - -(define (nreverse l) - (let ((prev nil)) - (while (consp l) - (set 'l (prog1 (cdr l) - (rplacd l (prog1 prev - (set 'prev l)))))) - prev)) - -(defmacro let* (binds . body) - (cons (list 'lambda (map car binds) - (cons progn - (nconc (map (lambda (b) (cons 'setq b)) binds) - body))) - (map (lambda (x) nil) binds))) - -(defmacro labels (binds . body) - (cons (list 'lambda (map car binds) - (cons progn - (nconc (map (lambda (b) - (list 'setq (car b) (cons 'lambda (cdr b)))) - binds) - body))) - (map (lambda (x) nil) binds))) - -(defmacro when (c . body) (list if c (f-body body) nil)) -(defmacro unless (c . body) (list if c nil (f-body body))) - -(defmacro dotimes (var . body) - (let ((v (car var)) - (cnt (cadr var))) - (list 'let (list (list v 0)) - (list while (list < v cnt) - (list prog1 (f-body body) (list 'setq v (list + v 1))))))) - -(defun map-int (f n) - (let ((acc nil)) - (dotimes (i n) - (setq acc (cons (f i) acc))) - (nreverse acc))) - -; property lists -(setq *plists* nil) - -(defun symbol-plist (sym) - (cdr (or (assoc sym *plists*) '(())))) - -(defun set-symbol-plist (sym lst) - (let ((p (assoc sym *plists*))) - (if (null p) ; sym has no plist yet - (setq *plists* (cons (cons sym lst) *plists*)) - (rplacd p lst)))) - -(defun get (sym prop) - (let ((pl (symbol-plist sym))) - (if pl - (let ((pr (member prop pl))) - (if pr (cadr pr) nil)) - nil))) - -(defun put (sym prop val) - (let ((p (assoc sym *plists*))) - (if (null p) ; sym has no plist yet - (setq *plists* (cons (list sym prop val) *plists*)) - (let ((pr (member prop p))) - (if (null pr) ; sym doesn't have this property yet - (rplacd p (cons prop (cons val (cdr p)))) - (rplaca (cdr pr) val))))) - val) - -; setf -; expands (setf (place x ...) v) to (mutator (f x ...) v) -; (mutator (identity x ...) v) is interpreted as (mutator x ... v) -(setq *setf-place-list* - ; place mutator f - '((car rplaca identity) - (cdr rplacd identity) - (caar rplaca car) - (cadr rplaca cdr) - (cdar rplacd car) - (cddr rplacd cdr) - (caaar rplaca caar) - (caadr rplaca cadr) - (cadar rplaca cdar) - (caddr rplaca cddr) - (cdaar rplacd caar) - (cdadr rplacd cadr) - (cddar rplacd cdar) - (cdddr rplacd cddr) - (get put identity) - (aref aset identity) - (symbol-function set identity) - (symbol-value set identity) - (symbol-plist set-symbol-plist identity))) - -(defun setf-place-mutator (place val) - (if (symbolp place) - (list 'setq place val) - (let ((mutator (assoc (car place) *setf-place-list*))) - (if (null mutator) - (error '|setf: error: unknown place | (car place)) - (if (eq (caddr mutator) 'identity) - (cons (cadr mutator) (append (cdr place) (list val))) - (list (cadr mutator) - (cons (caddr mutator) (cdr place)) - val)))))) - -(defmacro setf args - (f-body - ((label setf- - (lambda (args) - (if (null args) - nil - (cons (setf-place-mutator (car args) (cadr args)) - (setf- (cddr args)))))) - args))) - -(defun revappend (l1 l2) (nconc (reverse l1) l2)) -(defun nreconc (l1 l2) (nconc (nreverse l1) l2)) - -(defun builtinp (x) - (and (atom x) - (not (symbolp x)) - (not (numberp x)))) - -(defun self-evaluating-p (x) - (or (eq x nil) - (eq x t) - (and (atom x) - (not (symbolp x))))) - -; backquote -(defmacro backquote (x) (bq-process x)) - -(defun splice-form-p (x) - (or (and (consp x) (or (eq (car x) '*comma-at*) - (eq (car x) '*comma-dot*))) - (eq x '*comma*))) - -(defun bq-process (x) - (cond ((self-evaluating-p x) x) - ((atom x) (list quote x)) - ((eq (car x) 'backquote) (bq-process (bq-process (cadr x)))) - ((eq (car x) '*comma*) (cadr x)) - ((not (any splice-form-p x)) - (let ((lc (lastcdr x)) - (forms (map bq-bracket1 x))) - (if (null lc) - (cons 'list forms) - (nconc (cons 'nlist* forms) (list (bq-process lc)))))) - (t (let ((p x) (q '())) - (while (and (consp p) - (not (eq (car p) '*comma*))) - (setq q (cons (bq-bracket (car p)) q)) - (setq p (cdr p))) - (cons 'nconc - (cond ((consp p) (nreconc q (list (cadr p)))) - ((null p) (nreverse q)) - (t (nreconc q (list (bq-process p)))))))))) - -(defun bq-bracket (x) - (cond ((atom x) (list cons (bq-process x) nil)) - ((eq (car x) '*comma*) (list cons (cadr x) nil)) - ((eq (car x) '*comma-at*) (list 'copy-list (cadr x))) - ((eq (car x) '*comma-dot*) (cadr x)) - (t (list cons (bq-process x) nil)))) - -; bracket without splicing -(defun bq-bracket1 (x) - (if (and (consp x) (eq (car x) '*comma*)) - (cadr x) - (bq-process x))) diff --git a/todo b/todo deleted file mode 100644 index 8658f60..0000000 --- a/todo +++ /dev/null @@ -1,1199 +0,0 @@ -* setf -* plists -* backquote -* symbol< (make < generic), generic compare function -? (cdr nil) should be nil -* multiple-argument mapcar -? multi-argument apply. for builtins, just push them. for lambdas, must - cons together the evaluated arguments. -? option *print-shared*. if nil, it still handles circular references - but does not specially print non-circular shared structure -? option *print-circle* -* read support for #' for compatibility -* #\c read character as code (including UTF-8 support!) -* #| |# block comments -? here-data for binary serialization. proposed syntax: - #>size:data, e.g. #>6:000000 -? better read syntax for packed arrays, e.g. #double[3 1 4] -* use syntax environment concept for user-defined macros to plug - that hole in the semantics -* make more builtins generic. if typecheck fails, call out to the - generic version to try supporting more types. - compare/equal - +-*/< for all numeric types - length for all sequences - ? aref/aset for all sequences (vector, list, c-array) - ? copy -* fixnump, all numeric types should pass numberp -- make sure all uses of symbols don't assume symbols are unmovable without - checking ismanaged() -* eliminate compiler warnings -* fix printing nan and inf -* move to "2.5-bit" type tags -? builtin abs() -* try adding optional arguments, (lambda (x (opt 0)) ...), see if performance - is acceptable -* (syntax-environment) to return it as an assoc list -* (environment) for variables, constantp -* prettier printing - -* readable gensyms and #: - . #:n reads similar to #n=#.(gensym) the first time, and #n# after -* circular equal -* integer/truncate function -? car-circularp, cdr-circularp, circularp -- hashtable. plan as equal-hash, over three stages: - 1. first support symbol and fixnum keys, use ptrhash. only values get - relocated on GC. - 2. create a version of ptrhash that uses equal() and hash(). if a key is - inserted requiring this, switch vtable pointer to use these functions. - both keys and values get relocated on GC. - 3. write hash() for pairs and vectors. now everything works. -- expose eq-hashtable to user -- other backquote optimizations: - * (nconc x) => x for any x - . (copy-list (list|append|nconc ...)) => (list|append|nconc ...) - * (apply vector (list ...)) => (vector ...) - * (nconc (cons x nil) y) => (cons x y) -* let form without initializers (let (a b) ...), defaults to nil -* print (quote a) as 'a, same for ` etc. - -- template keyword arguments. you write -(template (:test eq) (:key caar) - (defun assoc (item lst) - (cond ((atom lst) ()) - ((:test (:key lst) item) (car lst)) - (t (assoc item (cdr lst)))))) - -This writes assoc as a macro that produces a call to a pre-specialized -version of the function. For example - (assoc x l :test equal) -first tries to look up the variant '(equal caar) in the dictionary for assoc. -If it doesn't exist it gets generated and stored. The result is a lambda -expression. -The macro returns ((lambda (item lst) ) x l). -We might have to require different syntax for template invocations inside -template definitions, such as - ((t-instance assoc eq :key) item lst) -which passes along the same key but always uses eq. -Alternatively, we could use the keysyms without colons to name the values -of the template arguments, so the keysyms are always used as markers and -never appear to have values: -(template (:test eq) (:key caar) - (defun assoc? (item lst) - (cond ((atom lst) ()) - ((test (key lst) item) ... - ... - (assoc x y :test test :key key) -This would be even easier if the keyword syntax were something like - (: test eq) - - -possible optimizations: -* delay environment creation. represent environment on the stack as - alternating symbols/values, or if cons instead of symbol then traverse - as assoc list. only explicitly cons the whole thing when making a closure -* cons_reserve(n) interface, guarantees n conses available without gc. - it could even link them together for you more efficiently -* assoc builtin -* special check for constant symbol when evaluating head since that's likely -* remove the loop from cons_reserve. move all initialization to the loops - that follow calls to cons_reserve. -- case of lambda expression in head (as produced by let), can just modify - env in-place in tail position -- allocate memory by mmap'ing a large uncommitted block that we cut - in half. then each half heap can be grown without moving addresses. -* try making (list ...) a builtin by moving the list-building code to - a static function, see if vararg call performance is affected. -- try making foldl a builtin, implement table iterator as table.foldl - . not great, since then it can't be CPS converted -* represent lambda environment as a vector (in lispv) -x setq builtin (didn't help) -* list builtin, to use cons_reserve -unconventional interpreter builtins that can be used as a compilation -target without moving away from s-expressions: -- (*global* . a) ; special form, don't look in local env first -- (*local* . 2) ; direct stackframe access -for internal use: -* a special version of apply that takes arguments on the stack, to avoid - consing when implementing "call-with" style primitives like trycatch, - hashtable-foreach, or the fl_apply API -- partial_apply, reapply interface so other iterators can use the same - fast mechanism as for -* try this environment representation: - for all kinds of functions (except maybe builtin special forms) push - all arguments on the stack, either evaluated or not. - for lambdas, push the lambda list and next-env pointers. - to capture, save the n+2 pointers to a vector - . this uses n+2 heap or stack words per environment instead of 2n+1 words - . argument handling is more uniform which could lead to simplifications, - and a more efficient apply() entry point - . disadvantage is looking through the lambda list on every lookup. maybe - improve by making lambda lists vectors somehow? -* fast builtin bounded iteration construct (for lo hi (lambda (x) ...)) -* represent guest function as a tagged function pointer; allocate nothing -- when an instance of (array type n) is requested, use (array type) - instead, unless the value is part of an aggregate (e.g. struct). - . this avoids allocating a new type for every size. - . and/or add function array.alloc -x preallocate all byte,int8,uint8 values, and some wchars (up to 0x31B7?) - . this made no difference in a string.map microbenchmark -- use faster hash/compare in tables where the keys are eq-comparable -- a way to do open-input-string without copying - -bugs: -* with the fully recursive (simpler) relocate(), the size of cons chains - is limited by the process stack size. with the iterative version we can - have unlimited cdr-deep structures. -* in #n='e, the case that makes the cons for 'e needs to use label fixup -* symbol token |.| does not work -* ltable realloc not multiplying by sizeof(unsigned long) -* not relocating final cdr in iterative version if it is a vector -- (setf (car x) y) doesn't return y -* reader needs to check errno in isnumtok -* prettyprint size measuring is not utf-8 correct -* stack is too limited. - . add extra heap-allocated stack segments as needed. -* argument list length is too limited. - need to fix it for: +,-,*,/,&,|,$,list,vector,apply,string,array - . for builtins, make Nth argument list of rest args - . write a function to evaluate directly from list to list, use it for - Nth arg and for user function rest args - . modify vararg builtins accordingly -* filter should be stable. right now it reverses. - - -femtoLisp3...with symbolic C interface - -c values are builtins with value > N_BUILTINS -((u_int32_t*)cvalue)[0] & 0x3 must always be 2 to distinguish from vectors - -typedef struct _cvtable_t { - void (*relocate)(struct _cvalue_t *); - void (*free)(struct _cvalue_t *); - void (*print)(struct _cvalue_t *, FILE *); -} cvtable_t; - -c type representations: -symbols void, [u]int[8,16,32,64], float, double, [u]char, [u]short, -[u]int, [u]long, lispvalue -(c-function ret-type (argtype ...)) -(array type[ N]) -(struct ((name type) (name type) ...)) -(union ((name type) (name type) ...)) -(mlayout ((name type offset) (name type offset) ...)) -(enum (name1 name2 ...)) -(pointer type) - -constructors: -([u]int[8,16] n) -([u]int32 hi lo) -([u]int64 b3 b2 b1 b0) -(float hi lo) or (float "3.14") -(double b3 b2 b1 b0) or (double "3.14") -(array ctype val ...) -(struct ((name type) ...) val ...) -(pointer ctype) ; null pointer -(pointer cvalue) ; constructs pointer to the given value - ; same as (pointer (typeof x) x) -(pointer ctype cvalue) ; pointer of given type, to given value -(pointer ctype cvalue addr) ; (ctype*)((char*)cvalue + addr) -(c-function ret-type (argtype ...) ld-symbol-name) - -? struct/enum tag: - (struct 'tag ) or (pointer (struct tag)) - where tag is a global var with a value ((name type) ...) - - -representing c data from lisp is the tricky part to make really elegant and -efficient. the most elegant but too inefficient option is not to have opaque -C values at all and always marshal to/from native lisp values like #int16[10]. -the next option is to have opaque values "sometimes", for example returning -them from C functions but printing them using their lisp representations. -the next option is to relax the idea that C values of a certain type have a -specific lisp structure, and use a coercion system that "tries" to translate -a lisp value to a specified C type. for example [0 1 2], (0 1 2), -#string[0 1 2], etc. might all be accepted by a C function taking int8_t*. -you could say (c-coerce ) and get a cvalue back or -an error if the conversion fails. - -the final option is to have cvalues be the only officially-sanctioned -representation of c data, and make them via constructors, like -(int32 hi lo) returns an int32 cvalue -(struct '((name type) (name type) ...) a b ...) makes a struct -there is a constructor function for each primitive C type. -you can print these by brute force as e.g. #.(int32 hi lo) -then all checking just looks like functions checking their arguments - -this option seems almost ideal. what's wrong with it? -. to construct cvalues from lisp you have to build code instead of data -. it seems like it should take more explicit advantage of tagged vectors -. should you accept multiple forms? for example - (array 'int8 0 1 2) or (array 'int8 [0 1 2]) - if you're going to be that permissive, why not allow [0 1 2] to be passed - directly to a function that expects int8_t* and do the conversion - implicitly? - . even if these c-primitive-constructor functions exist, you can still - write things like c-coerce (in lisp, even) and hack in implicit - conversion attempts when something other than a cvalue is passed. -. the printing code is annoying, because it's not enough to print readably, - you have to print evaluably. - . solution: constructor notation, #int32(hi lo) - -in any case, "opaque" cvalues will not really be opaque because we want to -know their types and be able to take them apart on the byte level from lisp. -C code can get references to lisp values and manipulate them using lisp -operations like car, so to be fair it should work vice-versa; give -c references to lisp code and let it use c operations like * on them. -you can write lisp in c and c in lisp, though of course you don't usually -want to. however, c written in lisp can be generated by a macro, printed, -and fed to TCC for compilation. - - -for a struct the names and types are parameters of the type, not the -constructor, so it seems more correct to do - -((struct (name type) (name type) ...) (val val ...)) - -where struct returns a constructor. but this isn't practical because it -can't be printed in constructor notation and the type is a lambda rather -than a more sensible expression. - - -notice constructor calls and type representations are "similar". they -should be related formally: - -(define (new type) - (if (symbolp type) (apply (eval type) ()) - (apply (eval (car type)) (cdr type)))) - -NOTE: this relationship is no longer true. we don't want to have to -construct 1 cvalue from 1 lisp value every time, since that could -require allocating a totally redundant list or vector. it should be -possible to make a cvalue from a series of lisp arguments. for -example there are now 2 different ways to make an array: - -1) from series of arguments: (array type val0 val1 ...) -2) from 1 (optional) value: (c-value '(array int8[ size])[ V]) - -constructors will internally use the second form to initialize elements -of aggregates. e.g. 'array' in the first case will conceptually call - (c-value type val0) - (c-value type val1) - ... - - -for aggregate types, you can keep a variable referring to the relevant -piece: - -(setq point '((x int) (y int))) -(struct point 2 3) ; looks like c declaration 'struct point x;' - -a type is a function, so something similar to typedef is achieved by: - -(define (point_t vals) (struct point vals)) - -design points: -. type constructors will all be able to take 1 or 0 arguments, so i could say - (new (typeof val)) ; construct similar - (define (new type) - (if (symbolp type) (apply (eval type) ()) - (apply (eval (car type)) (cdr type)))) -. values can be marked as autorelease (1) if user says so, (2) if we can - prove that it's ok (e.g. we only allocated the value using malloc because - it is too large to move on every GC). - in the future you should be able to specify an arbitrary finalization - function, not just free(). -. when calling a C function, a value of type_t can be passed to something - expecting a type_t* by taking the address of the representation. BUT - this is dangerous if the C function might save a reference. - a type_t* can be passed as a type_t by copying the representation. -. you can use (pointer v) to switch v to "malloc'd representation", in - which case the value is no longer autoreleased, but you can do whatever - you want with the pointer. (other option is to COPY v when making a - pointer to it, but this still doesn't prevent C from holding a reference - too long) - - -add a cfunction binding to symbols. you register in C simply by setting -this binding to a function pointer, then - -(defun open (path flags) - ; could insert type checks here - (ccall 'int32 'open path flags)) - -(setq fd (open "path" 0)) - -using libdl you could even omit the registration step and extra binding - -this is possible: -(defun malloc (size) - (ccall `(array int8 ,size) 'malloc size)) - ;ret type ;f name ; . args - - -vtable: -we'd like to be able to define new lisp "types", like vectors -and hash tables, using this. there needs to be a standard value interface -you can implement in C and attach a vtable to some c values. -interface: relocate, finalize, print(, copy) - -implementation plan: -- write cvalue constructors -- if a head evaluates to a cvalue, call the pointer directly with the arg array - . this is the "guest function" interface, a C function written specifically - to the femtolisp API. its type must be - '(c-function lispvalue ((pointer lispvalue) uint32)) - which corresponds to - value_t func(value_t *args, u_int32_t nargs); - . this interface is useful for writing additional builtins, types, - interpreter extensions, etc. more efficient. - . one of these functions could also be called with - (defun func args - (ccall 'func 'lispvalue (array 'lispvalue args) (length args))) - - these functions are effectively builtins and should have names so they - can be printed as such. - . have a registration function - void guest_function(value_t (*f)(value_t*,u_int32_t), const char *name); - so at least the function type can be checked from C - . set a flags bit for functions registered this way so we can identify - them quickly - -- ccall lisp builtin, (ccall rettype name . args). if name has no cfunc - binding, looks it up lazily with dlsym and stores the result. - this is a guest function that handles type checking, translation, and - invocation of foreign c functions. - -- you could register builtins from lisp like this: - (defun dlopen (name flags) (ccall '(pointer void) 'dlopen name flags)) - (defun dlsym (handle name type) (ccall type 'dlsym handle name)) - (define lisp-process (dlopen nil 0)) - (define vector-sym - (dlsym lisp-process 'int_vector - '(function lispvalue (pointer lispvalue) uint32))) - (ccall 'void 'guest_function vector-sym 'vector) - -- write c extensions cref, cset, typeof, sizeof, cvaluep -* read, print, vectorp methods for vectors -- quoted string "" reading, produces #(c c c c ...) -* get rid of primitive builtins read,print,princ,load,exit, - implement using ccall - - -other possible design: -- just add two builtins, call and ccall. - (call 'name arg arg arg) lisp guest function interface - we can say e.g. - (defmacro vector args `(call 'vector ,.args)) -- basically the question is whether to introduce a new kind of callable - object or to do everything through the existing builtin mechanism - . macros cannot be applied, so without a new kind of callable 'vector' - would have to be a lisp function, entailing argument consing... - (defun builtin (name) - (guest-function name - (dlsym lisp-process name '(function value (pointer value) uint32)))) - then you can print a guest function as e.g. - #.(builtin 'vector) - -#name(x y z) reads as a tagged vector -#(x y z) is the same as #vector(x y z) -should be internally the same as well, so non-taggedness does not formally -exist. - - -then we can write the vector clause in backquote as e.g. - -(if (vectorp x) - (let ((body (bq-process (vector-to-list x)))) - (if (eq (tag x) 'vector) - (list 'list-to-vector body) - (list 'apply 'tagged-vector - (list cons (list quote (tag x)) body)))) - (list quote x)) - - -setup plan: -* create source directory and svn repository, move llt sources into it -* write femtolisp.h, definitions for extensions to #include -- add fl_ prefix to all exported functions -* port read and print to llt iostreams -* get rid of flutils; use ptrhash instead -* builtinp needs to be a builtin ;) to distinguish lisp builtins from cvalues -* allocation and gc for cvalues -- interface functions fl_list(...), fl_apply - e.g. fl_apply(fl_eval(fl_symbol("+")), fl_list(fl_number(2),fl_number(3))) - and fl_symval("+"), fl_cons, etc. - ------------------------------------------------------------------------------ - -vector todo: -* compare for vectors -- (aref v i j k) does (reduce aref v '(i j k)); therefore (aref v) => v -- (aref v ... [1 2 3] ...) vectorized indexing -- make (setf (aref v i j k) x) expand to (aset (aref v i j) k x) -these should be done using the ccall interface: -- concatenate -- copy-vec -- (range i j step) to make integer ranges -- (rref v start stop), plus make it settable! (rset v start stop rhs) -lower priority: -- find (strstr) - -functions to be generic over vec/list: -* compare, equal, length - -constructor notation: - -#func(a b c) does (apply func '(a b c)) - ------------------------------------------------------------------------------ - -how we will allocate cvalues - -a vector's size will be a lisp-value number. we will set bit 0x2 to indicate -a resize request, and bit 0x1 to indicate that it's actually a cvalue. - -every cvalue will have the following fields, followed by some number of -words according to how much space is needed: - - value_t size; // | 0x2 - cvtable_t *vtable; - struct { -#ifdef BITS64 - unsigned pad:32; -#endif - unsigned whatever:27; - unsigned mark:1; - unsigned hasparent:1; - unsigned islispfunction:1; - unsigned autorelease:1; - unsigned inlined:1; - } flags; - value_t type; - size_t len; // length of *data in bytes - //void *data; // present if !inlined - //value_t parent; // present if hasparent - -size/vtable have the same meaning as vector size/elt[0] for relocation -obviously we only relocate parent and type. if vtable->relocate is present, -we call it at the end of the relocate process, and it must touch every -lisp value reachable from it. - -when a cvalue is created with a finalizer, its address is added to a special -list. before GC, everything in that list has its mark bit set. when -we relocate a cvalue, clear the bit. then go through the list to call -finalizers on dead values. this is O(n+m) where n is amt of live data and m -is # of values needing finalization. we expect m << heapsize. - ------------------------------------------------------------------------------ - -Goal: bootstrap a lisp system where we can do "anything" purely in lisp -starting with the minimal builtins needed for successive levels of -completeness: - -1. Turing completeness -quote, if, lambda, eq, atom, cons, car, cdr - -2. Naming -set - -3. Control flow -progn, prog1, apply, eval -call/cc needed for true completeness, but we'll have attempt, raise - -4. Predicate completeness -symbolp, numberp, builtinp - -5. Syntax -macro - -6. I/O completeness -read, print - -7. Mutable state -rplaca, rplacd - -8. Arithmetic completeness -+, -, *, /, < - -9. The missing data structure(s): vector -alloc, aref, aset, vectorp, length - -10. Real-world completeness (escape hatch) -ccall - ---- -11. Misc unnecessary -while, label, cond, and, or, not, boundp, vector - ------------------------------------------------------------------------------ - -exception todo: - -* silence 'in file' errors when user frame active -* add more useful data to builtin exception types: - (UnboundError x) - (BoundsError vec index) - (TypeError fname expected got) - (Error v1 v2 v3 ...) -* attempt/raise, rewrite (error) in lisp -* more intelligent exception printers in toplevel handler - ------------------------------------------------------------------------------ - -lisp variant ideas - -- get rid of separate predicates and give every value the same structure - ala mathematica - . (tag 'a) => symbol - (tag '(a b)) => a - (tag 'symbol 'a) => a - (tag 'blah 3) => (blah 3) -- have only vectors, not cons cells (sort of like julia) - . could have a separate tag field as above - -- easiest way to add vectors: - . allocate in same heap with conses, have a tag, size, then elements - (each elt must be touched on GC for relocation anyway, so might as well - copy collect it) - . tag pointers as builtins, we identify them as builtins with big values - . write (vector) in C, use it from read and eval - -8889314663 comcast net # - ------------------------------------------------------------------------------ - -cvalues reserves the following global symbols: - -int8, uint8, int16, uint16, int32, uint32, int64, uint64 -char, uchar, wchar, short, ushort, int, uint, long, ulong -float, double -struct, array, enum, union, function, void, pointer, lispvalue - -it defines (but doesn't reserve) the following: - -typeof, sizeof, autorelease, guestfunction, ccall - - -user-defined types and typedefs: - -the rule is that a type should be viewed as a self-evaluating constant -like a number. if i define a complex_t type of two doubles, then -'complex_t is not a type any more than the symbol 'x could be added to -something just because it happened to have the value 2. - -; typedefs from lisp -(define wchar_t 'uint32) -(define complex_t '(struct ((re double) (im double)))) - -; use them -(new complex_t) -(new `(array ,complex_t 10)) -(array complex_t 10) - -BUT - -(array 'int32 10) - -because the primitive types *are* symbols. the fact that they have values is -just a convenient coincidence that lets you do e.g. (int32 0) - - -; size-annotate a pointer -(setq p (ccall #c-function((pointer void) (ulong) malloc) n) -(setq a (deref p `(array int8 ,n))) - -cvalues todo: - -* use uint32_t instead of wchar_t in C code -- make sure empty arrays and 0-byte types really work -* allow int constructors to accept other int cvalues -* array constructor should accept any cvalue of the right size -* make sure cvalues participate well in circular printing -* float, double -- struct, union (may want to start with more general layout type) -- pointer type, function type -* finalizers -- functions autorelease, guestfunction -- cref/cset/byteref/byteset -* wchar type, wide character strings as (array wchar) -* printing and reading strings -- ccall -- anonymous unions -* fix princ for cvalues -* make header size for primitives <= 8 bytes, even on 64-bit arch -- more efficient read for #array(), so it doesn't need to build a pairlist -? lispvalue type - . keep track of whether a cvalue leads to any lispvalues, so they can - be automatically relocated (?) - -* string constructor/concatenator: -(string 'sym #char(65) #wchar(945) "blah" 23) - ; gives "symA\u03B1blah23" -"ccc" reads to (array char) - -low-level functions: -; these are type/bounds-checked accesses -- (cref cvalue key) ; key is field name or index. access by reference. -- (aref cvalue key) ; access by value, returns fixnums where possible -- (cset cvalue key value) ; key is field name, index, or struct offset - . write&use conv_from_long to put fixnums into typed locations - . aset is the same -* (copy cv) -- (offset type|cvalue field [field ...]) -- (eltype type field [field ...]) -- (memcpy dest-cv src-cv) -- (memcpy dest doffs src soffs nbytes) -- (bswap cvalue) -- (c2lisp cvalue) ; convert to sexpr form -* (typeof cvalue) -* (sizeof cvalue|type) -- (autorelease cvalue) ; mark cvalue as free-on-gc -- (deref pointer[, type]) ; convert an arbitrary pointer to a cvalue - ; this is the unsafe operation - -; (sizeof '(pointer type)) == sizeof(void*) -; (sizeof '(array type N)) == N * sizeof(type) - -(define (reinterpret-cast cv type) - (if (= (sizeof cv) (sizeof type)) - (deref (pointer 'void cv) type) - (error "Invalid cast"))) - -a[n].x looks like (cref (cref a n) 'x), (reduce cref head subs) - -things you can do with cvalues: - -. call native C functions from lisp code without wrappers -. wrap C functions in pure lisp, automatically inheriting some degree - of type safety -. use lisp functions as callbacks from C code -. use the lisp garbage collector to reclaim malloc'd storage -. annotate C pointers with size information for bounds checking -. attach symbolic type information to a C data structure, allowing it to - inherit lisp services such as printing a readable representation -. add datatypes like strings to lisp -. use more efficient represenations for your lisp programs' data - - -family of cvalue representations. -relevant attributes: - . large -- needs full size_t to represent size - . inline -- allocated along with metadata - . prim -- no stored type; uses primtype bits in flags - . hasdeps -- depends on other values to stay alive - -these attributes have the following dependencies: - . large -> !inline - . prim -> !hasdeps && !large - -so we have the following possibilities: - -large inline prim hasdeps rep# - 0 0 0 0 0 - 0 0 0 1 1 - - 0 0 1 0 2 - 0 1 0 0 3 - 0 1 0 1 4 - 0 1 1 0 5 - - 1 0 0 0 6 - 1 0 0 1 7 - -we need to be able to un-inline data, so we need: -change 3 -> 0 (easy; write pointer over data) -change 4 -> 1 -change 5 -> 2 (also easy) - - -rep#0&1: (!large && !inline && !prim) -typedef struct { - cvflags_t flags; - value_t type; - value_t deps; - void *data; /* points to malloc'd buffer */ -} cvalue_t; - -rep#3&4: (!large && inline && !prim) -typedef struct { - cvflags_t flags; - value_t type; - value_t deps; - /* data goes here inlined */ -} cvalue_t; - - -rep#2: (prim && !inline) -typedef struct { - cvflags_t flags; - void *data; /* points to (tiny!) malloc'd buffer */ -} cvalue_t; - -rep#5: (prim && inline) -typedef struct { - cvflags_t flags; - /* data goes here inlined */ -} cvalue_t; - - -rep#6&7: (large) -typedef struct { - cvflags_t flags; - value_t type; - value_t deps; - void *data; /* points to malloc'd buffer */ - size_t len; -} cvalue_t; - ------------------------------------------------------------------------------ - -times for lispv: - -color 2.286s -sort 0.181s -fib34 5.205s -mexpa 0.329s - ------------------------------------------------------------------------------ - -finalization algorithm that allows finalizers written in lisp: - -right after GC, go through finalization list (a weak list) and find objects -that didn't move. relocate them (bring them back to life) and push them -all onto the stack. remove all from finalization list. - -call finalizer for each value. - -optional: after calling a finalizer, make sure the object didn't get put -back on the finalization list, remove if it did. -if you don't do this, you can make an unkillable object by registering a -finalizer that re-registers itself. this could be considered a feature though. - -pop dead values off stack. - - ------------------------------------------------------------------------------ - -femtolisp semantics - -eval* is an internal procedure of 2 arguments, expr and env, invoked -implicitly on input. -The user-visible procedure eval performs eval* e Env () - -eval* Symbol s E => lookup* s E -eval* Atom a E => a -... special forms ... quote arg, if a b c, other symbols from syntax env. -eval* Cons f args E => - -First the head expression, f, is evaluated, yielding f-. -Then control is passed to #.apply f- args - #.apply is the user-visible apply procedure. - (here we imagine there is a user-invisible environment where f- is - bound to the value of the car and args is bound to the cdr of the input) - - -Now (apply b lst) where b is a procedure (i.e. satisfies functionp) is -identical to -(eval (map (lambda (e) `',e) (cons b lst))) - ------------------------------------------------------------------------------ - -design of new toplevel - -system.lsp contains definitions of (load) and (toplevel) and is loaded -from *install-dir* by a bootstrap loader in C. at the end of system.lsp, -we check whether (load) is builtin. if it is, we redefine it and reload -system.lsp with the new loader. the C code then invokes (toplevel). - -(toplevel) either runs a script or a repl using (while T (trycatch ...)) - -(load) reads and evaluates every form, keeping track of defined functions -and macros (at the top level), and grabs a (main ...) form if it sees -one. it applies optimizations to every definition, then invokes main. - -an error E during load should rethrow `(load-error ,filename ,E) -such exceptions can be printed recursively - -lerror() should make a lisp string S from the result of sprintf, then -raise `(,e ,S). first argument e should be a symbol. - - -new expansion process: - -get rid of macroexpanding versions of define and define-macro -macroexpand doesn't expand (define ...) - macroexpand implements let-syntax -add lambda-expand which applies f-body to the bodies of lambdas, then - converts defines to set! -call expand on every form before evaluating - (define (expand x) (lambda-expand (macroexpand x))) -(define (eval x) (%eval (expand x))) -reload system.lsp with the new eval - ------------------------------------------------------------------------------ - -String API - -*string - append/construct -*string.inc - (string.inc s i [nchars]) -*string.dec -*string.count - # of chars between 2 byte offsets -*string.char - char at byte offset -*string.sub - substring between 2 byte offsets -*string.split - (string.split s sep-chars) -*string.trim - (string.trim s chars-at-start chars-at-end) -*string.reverse -*string.find - (string.find s str|char [offs]), or nil if not found - string.rfind -*string.encode - to utf8 -*string.decode - from utf8 to UCS -*string.width - # columns -*string.map - (string.map f s) - - -IOStream API - -*read - (read[ stream]) ; get next sexpr from stream -*print -*princ -*file - iostream - (stream[ cvalue-as-bytestream]) -*buffer - fifo - socket -*io.eof? -*io.flush -*io.close -*io.discardbuffer -*io.write - (io.write s cvalue [start [count]]) -*io.read - (io.read s ctype [len]) -*io.getc - get utf8 character -*io.putc - io.peekc -*io.readline -*io.readuntil -*io.copy - (io.copy to from [nbytes]) -*io.copyuntil - (io.copy to from byte) - io.pos - (io.pos s [set-pos]) - io.seek - (io.seek s offset) - io.seekend - move to end of stream - io.trunc - io.read! - destructively take data -*io.tostring! -*io.readlines -*io.readall -*print-to-string -*princ-to-string - - -*path.exists? - path.dir? - path.combine - path.parts - path.absolute - path.simplify - path.tempdir - path.tempname - path.homedir -*path.cwd - - -*time.now - time.parts - time.fromparts -*time.string -*time.fromstring - - -*os.name -*os.getenv -*os.setenv - os.execv - - -*rand -*randn -*rand.uint32 -*rand.uint64 -*rand.double -*rand.float - ------------------------------------------------------------------------------ - - * new print algorithm - 1. traverse & tag all conses to be printed. when you encounter a cons - that is already tagged, add it to a table to give it a #n# index - 2. untag a cons when printing it. if cons is in the table, print - "#n=" before it in the car, " . #n=" in the cdr. if cons is in the - table but already untagged, print #n# in car or " . #n#" in the cdr. - * read macros for #n# and #n= using the same kind of table - * also need a table of read labels to translate from input indexes to - normalized indexes (0 for first label, 1 for next, etc.) - * read macro #. for eval-when-read. use for printing builtins, e.g. "#.eq" - ------------------------------------------------------------------------------ - -prettyprint notes - -* if head of list causes VPOS to increase and HPOS is a bit large, then -switch to miser mode, otherwise default is ok, for example: - -> '((lambda (x y) (if (< x y) x y)) (a b c) (d e f) 2 3 (r t y)) -((lambda (x y) - (if (< x y) x y)) (a b c) - (d e f) 2 3 - (r t y)) - -* (if a b c) should always put newlines before b and c - -* write try_predict_len that gives a length for easy cases like - symbols, else -1. use it to avoid wrapping symbols around lines - -* print defun, defmacro, label, for more like lambda (2 spaces) - -* *print-pretty* to control it - -* if indent gets too large, dedent back to left edge - ------------------------------------------------------------------------------ - -consolidated todo list as of 7/8: -* new cvalues, types representation -* use the unused tag for TAG_PRIM, add smaller prim representation -* finalizers in gc -* hashtable -* generic aref/aset -* expose io stream object -* new toplevel - -* make raising a memory error non-consing -* eliminate string copy in lerror() when possible -* fix printing lists of short strings - -* evaluator improvements, perf & debugging (below) -* fix make-system-image to save aliases of builtins -* reading named characters, e.g. #\newline etc. -- #+, #- reader macros -- printing improvements: *print-length*, keep track of horiz. position - per-stream so indenting works across print calls -- remaining c types -- remaining cvalues functions -- finish ios -* optional arguments -* keyword arguments -- some kind of record, struct, or object system -- improve test coverage - -expansion process bugs: -* expand default expressions for opt/keyword args (as if lexically in body) -* make bound identifiers (lambda and toplevel) shadow macro keywords -* to expand a body: - 1. splice begins - 2. add defined vars to env - 3. expand nondefinitions in the new env - . if one expands to a definition, add the var to the env - 4. expand RHSes of definitions -- add different spellings for builtin versions of core forms, like - $begin, $define, and $set!. they can be replaced when found during expansion, - and used when the compiler needs to generate them with known meanings. - -- special efficient reader for #array -- reimplement vectors as (array lispvalue) -- implement fast subvectors and subarrays - ------------------------------------------------------------------------------ - -cvalues redesign - -goals: -. allow custom types with vtables -. use less space, share types more -. simplify access to important metadata like length -. unify vectors and arrays - -typedef struct { - fltype_t *type; - void *data; - size_t len; // length of *data in bytes - union { - value_t parent; // optional - char _space[1]; // variable size - }; -} cvalue_t; - -#define owned(cv) ((cv)->type & 0x1) -#define hasparent(cv) ((cv)->type & 0x2) -#define isinlined(cv) ((cv)->data == &(cv)->_space[0]) -#define cv_class(cv) ((fltype_t*)(((uptrint_t)(cv)->type)&~3)) -#define cv_type(cv) (cv_class(cv)->type) -#define cv_len(cv) ((cv)->len) -#define cv_data(cv) ((cv)->data) -#define cv_numtype(cv) (cv_class(cv)->numtype) - -typedef struct _fltype_t { - value_t type; - int numtype; - size_t sz; - size_t elsz; - cvtable_t *vtable; - struct _fltype_t *eltype; // for arrays - struct _fltype_t *artype; // (array this) - int marked; -} fltype_t; - ------------------------------------------------------------------------------ - -new evaluator todo: - -* need builtin = to handle nans properly, fix equal? on nans -* builtin quasi-opaque function type - fields: signature, maxstack, bcode, vals, cloenv - function->vector -* make (for ...) a special form -* trycatch should require 2nd arg to be a lambda expression -* immediate load int8 instruction -* unlimited lambda lists - . need 32-bit argument versions of loada, seta, loadc, setc - . largs instruction to move args after MAX_ARGS from list to stack -* maxstack calculation, make Stack growable - * stack traces and better debugging support -* improve internal define -* try removing MAX_ARGS trickery -? apply optimization, avoid redundant list copying calling vararg fns -- let eversion -- variable analysis - avoid holding references to values in frames - captured by closures but not used inside them -* lambda lifting -* let optimization -* fix equal? on functions -* store function name -* have macroexpand use its own global syntax table -* be able to create/load an image file -* fix trace and untrace -* opcodes LOADA0, LOADA1, LOADC00, LOADC01 -- opcodes CAAR, CADR, CDAR, CDDR -- EQTO N, compare directly to stored datum N -- peephole opt - done: - not brf => brt - eq brf => brne - null brf => brnn - null brt => brn - null not brf => brn - cdr car => cadr - - not yet: - not brt => brf - constant+pop => nothing, e.g. 2-arg 'if' in statement position - loadt+brf => nothing - loadf+brt => nothing - loadt+brt => jmp - loadf+brf => jmp - ------------------------------------------------------------------------------ - -new stack organization: - -func -arg1 -... -argn -cloenv | -prev | -nargs | -ip | -captured | - -to call: -push func and arguments -args[nargs+3] = ip // save my state in my frame -assign nargs -goto top - -on entry: -push cloenv -push curr_frame (a global initialized to 0) -push nargs -SP += 1 -curr_frame = SP - -to return: -v = POP(); -SP = curr_frame -curr_frame = Stack[SP-4] -if (args == top_args) return v; -SP -= (5+nargs); -move Stack[curr_frame-...] back into locals -Stack[SP-1] = v -goto next_op - -to relocate stack: -for each segment { - curr_top = SP - f = curr_frame - while (1) { - for i=f, i= #required -grow frame by ntotal-nargs ; ntotal = #req+#opt+#kw -(sort keyword args into their places) -branch if arg bound around initializer for each opt arg - -example: (lambda (a (b 0) (c b))) - -minargs 1 -framesize 3 -brbound 1 L1 -load0 -seta 0 -L1: -brbound 2 L2 -loada 1 -seta 2 -L2: - ------------------------------------------------------------------------------ - -what needs more test coverage: - -- more error cases, lerrorf() cases -- printing gensyms -- gensyms with bindings -- listn(), isnumber(), list*, boolean?, function?, add2+ovf, >2arg add,div -- large functions, requiring long versions of branch opcodes -- setal, loadvl, (long arglist and lots of vals cases) -- aref/aset on c array -- printing everything -- reading floats, escaped symbols, multiline comment, octal chars in strs -- equal? on functions -- all cvalue ctors, string_from_cstrn() -- typeof, copy, podp, builtin() -- bitwise and logical ops -- making a closure in a default value expression for an optional arg -- gc during a catch block, then get stack trace - ------------------------------------------------------------------------------ - -5/4/10 todo: - -- flush and close open files on exit -* make function versions of opcode builtins by wrapping in a lambda, - stored in a table indexed by opcode. use in _applyn diff --git a/todo-scrap b/todo-scrap deleted file mode 100644 index 6403a11..0000000 --- a/todo-scrap +++ /dev/null @@ -1,41 +0,0 @@ -- readable gensyms. have uninterned symbols, but have all same-named - gensyms read to the same (eq) symbol within an expression. -- fat pointers, i.e. 64 bits on 32-bit platforms. we could have full 32-bit - integers too. the mind boggles at the possibilities. - (it would be great if everybody decided that pointer types should forever - be wider than address spaces, with some bits reserved for application use) -- any way at all to provide O(1) computed lookups (i.e. indexing). - CL uses vectors for this. once you have it, it's sufficient to get - efficient hash tables and everything else. - - could be done just by generalizing cons cells to have more than - car, cdr: c2r, c3r, etc. maybe (1 . 2 . 3 . 4 . ...) - all you need is a tag+size on the front of the object so the collector - knows how to deal with it. - (car x) == (ref x 0), etc. - (rplaca x v) == (rplac x 0 v), etc. - (size (cons 1 2)) == 2, etc. - - one possibility: if we see a cons whose CAR is tagptr(0x10,TAG_SYM), - then the CDR is the size and the following words are the elements. - . this approach is especially good if vectors are separate types from - conses - - another: add u_int32_t size to cons_t, making them all 50% bigger. - access is simpler and more uniform, without fully doubling the size like - we'd get with fat pointers. - -Notice that the size is one byte more than the number of characters in -the string. This is because femtoLisp adds a NUL terminator to make its -strings compatible with C. No effort is made to hide this fact. -But since femtoLisp tracks the sizes of cvalues, it doesn't need the -terminator itself. Therefore it treats zero bytes specially as rarely -as possible. In particular, zeros are only special in values whose type -is exactly (array char), and are only interpreted in the -following cases: -
    -
  • When printing strings, a final NUL is never printed. NULs in the -middle of a string are printed though. -
  • String constructors NUL-terminate their output. -
  • Explicit string functions (like strlen) treat NULs the same -way equivalent C functions would. -
-Arrays of uchar, int8, etc. are treated as raw data and zero bytes are -never special.