├── IMPLEMENTATION-NOTES.md ├── LICENSE ├── README.md ├── arith.cs ├── examples ├── eval-eval-fib15.l ├── eval-fib15.l ├── fact100.l ├── fib15.l ├── interp_in_thread.cs └── qsort.l ├── lisp.cs └── lisp.csproj /IMPLEMENTATION-NOTES.md: -------------------------------------------------------------------------------- 1 | # Implementation Notes 2 | 3 | 4 | 5 | ## 1. Overview 6 | 7 | The Lisp implementation of [lisp.cs](lisp.cs) is a translation of lisp.dart 8 | at [lisp-in-dart](https://github.com/nukata/lisp-in-dart) into C# 7. 9 | Below is an example of running lisp.cs with Mono 6.4.0 on macOS 10.14.6. 10 | 11 | ``` 12 | $ csc -r:System.Numerics.dll arith.cs lisp.cs 13 | Microsoft (R) Visual C# Compiler version 3.3.1-beta4-19462-11 (66a912c9) 14 | Copyright (C) Microsoft Corporation. All rights reserved. 15 | 16 | $ mono lisp.exe 17 | > (+ 5 6) 18 | 11 19 | > `(a b ,(car '(c d))) 20 | (a b c) 21 | > (let ((x '(a b c d))) 22 | (setcar (cddr x) x) 23 | x) 24 | (a b (a b (a ...) d) d) 25 | > (princ "\t789\n") 26 | 789 27 | "\t789\n" 28 | > (dump) 29 | (dotimes dolist while nconc last nreverse _nreverse assoc assq member memq listp 30 | or mapcar and append _append letrec let when if equal /= <= >= > setcdr setcar 31 | null = identity print consp not cdddr cddar cdadr cdaar caddr cadar caadr caaar 32 | cddr cdar cadr caar defun defmacro *version* dump exit apply symbol-name intern 33 | make-symbol gensym *gensym-counter* terpri princ prin1 truncate / - * + mod % < 34 | eql numberp stringp length rplacd rplaca list eq atom cons cdr car t) 35 | > *version* 36 | (2.0 "C# 7" "Nukata Lisp") 37 | > let 38 | #) '#0:0:vars) (progn (setq #0:1:vals #) 42 | '#0:1:vals) (cons (cons 'lambda (cons (#0:0:vars #1:0:args) #1:1:body)) (#0:1:v 43 | als #1:0:args)))> nil nil))> 44 | > (exit 0) 45 | $ 46 | ``` 47 | 48 | Some features of lisp.cs and lisp.dart are 49 | 50 | - It is basically a subset of Emacs Lisp. 51 | However, it is a Lisp-1 with static scoping. 52 | In short, it is a _Common Lisp-like Lisp-1_. 53 | 54 | - It makes proper tail calls always. 55 | 56 | - A quasi-quotation with backquote will be expanded when macros are expanded. 57 | 58 | - A circular list is printed with `...` finitely. 59 | 60 | - As an escape sequence within strings, you can use any of 61 | `\"`, `\\`, `\n`, `\r`, `\f`, `\b`, `\t`, `\v`. 62 | 63 | - `(dump)` returns a list of all global variables. 64 | The list does not include special forms such as `lambda` and `setq` 65 | since they are not variables. 66 | 67 | - `*version*` is a three-element list: 68 | the version number, the implementing language, 69 | and the name of implementation. 70 | 71 | - (`macro` _args_ _body_) is a special form that evaluates to a sort of 72 | anonymous function, or _macro expression_. 73 | The global environment will be used whenever (`macro` ...) evaluates. 74 | When you apply the resultant macro expression to a list of actual arguments, 75 | the arguments will not be evaluated and the result of the application 76 | will be evaluated again. 77 | Thus a variable bound to a macro expression works as a _macro_. 78 | 79 | - `defmacro` is a macro which binds a variable to a macro expression. 80 | 81 | - `defun` is a macro which binds a variable to a lambda expression. 82 | 83 | - `let` is a macro which applies a lambda expression to a list of initial 84 | values of variables. 85 | 86 | - Macros are _partially hygienic_. 87 | Free symbols within a macro expression will not be captured when the 88 | expression is applied (i.e., when the macro is expanded). 89 | 90 | 91 | The macro `let` is defined in the prelude as follows. 92 | 93 | ```Lisp 94 | (defmacro let (args &rest body) 95 | ((lambda (vars vals) 96 | (defun vars (x) 97 | (cond (x (cons (if (atom (car x)) 98 | (car x) 99 | (caar x)) 100 | (vars (cdr x)))))) 101 | (defun vals (x) 102 | (cond (x (cons (if (atom (car x)) 103 | nil 104 | (cadar x)) 105 | (vals (cdr x)))))) 106 | `((lambda ,(vars args) ,@body) ,@(vals args))) 107 | nil nil)) 108 | ``` 109 | 110 | 111 | Being _partially hygienic_, macros can avoid variable captures, 112 | provided that you always use the result of `(gensym)` for any symbol 113 | newly introduced to the expansion result. 114 | For example: 115 | 116 | ```Lisp 117 | (defmacro while (test &rest body) 118 | (let ((loop (gensym))) 119 | `(letrec ((,loop (lambda () (cond (,test ,@body (,loop)))))) 120 | (,loop)))) 121 | ``` 122 | 123 | See [lisp-in-dart/IMPLEMENTATION-NOTES §5](https://github.com/nukata/lisp-in-dart/blob/master/IMPLEMENTATION-NOTES.md#5) for details. 124 | 125 | ---------------------------------------- 126 | 127 | **Note:** 128 | I believe partially hygienic macros have ideal usefulness. 129 | If you like, you can define 130 | [anaphoric macros (Japanese page)](http://www.asahi-net.or.jp/~kc7k-nd/onlispjhtml/anaphoricMacros.html) 131 | by introducing a symbol (`it` in the following example) to the 132 | expansion result intentionally without `(gensym)`. 133 | 134 | ``` 135 | > (defmacro aif (test then else) 136 | `(let ((it ,test)) 137 | (if it ,then ,else) )) 138 | aif 139 | > (aif (+ 7 8 9) 140 | (print it) 141 | (print "?")) 142 | 24 143 | 24 144 | > 145 | ``` 146 | 147 | ---------------------------------------- 148 | 149 | 150 | 151 | ## 2. Internal Data Representation 152 | 153 | To represent data of the implemented language (Lisp), native types of the 154 | implementing language (C#) are used as they are, if possible. 155 | They are all treated as `object` uniformly. 156 | 157 | 158 | | Lisp Expression | Internal Representation | 159 | |:------------------------------------|:---------------------------------------| 160 | | numbers `1`, `2.3` | `int`, `double`, `BigInteger` | 161 | | strings `"abc"`, `"hello!\n"` | `string` | 162 | | `t` | `Sym` (user-defined) | 163 | | `nil` | `null` | 164 | | symbols `x`, `+` | `Sym` (user-defined) | 165 | | keywords `lambda`, `cond` | `Keyword` (derived from `Sym`) | 166 | | lists `(x 1 "2")`, `(y . 3)` | `Cell` (user-defined) | 167 | 168 | Below is the definition of the `Cell` class. 169 | 170 | ```CS 171 | /// Cons cell 172 | public sealed class Cell { 173 | /// Head part of the cons cell 174 | public object Car; 175 | /// Tail part of the cons cell 176 | public object Cdr; 177 | 178 | /// Construct a cons cell with its head and tail. 179 | public Cell(object car, object cdr) { 180 | Car = car; 181 | Cdr = cdr; 182 | } 183 | 184 | /// Make a simple string representation. 185 | /// Do not invoke this for any circular list. 186 | public override string ToString() => 187 | $"({Car ?? "null"} . {Cdr ?? "null"})"; 188 | 189 | /// Length as a list 190 | public int Length => FoldL(0, this, (i, e) => i + 1); 191 | } 192 | ``` 193 | 194 | 195 | Below is the definition of the `Sym` class. 196 | 197 | ```CS 198 | /// Lisp symbol 199 | public class Sym { 200 | /// The symbol's name 201 | public string Name { get; } 202 | 203 | /// Construct a symbol that is not interned. 204 | public Sym(string name) { 205 | Name = name; 206 | } 207 | 208 | /// Return the symbol's name 209 | public override string ToString() => Name; 210 | /// Return the hashcode of the symbol's name 211 | public override int GetHashCode() => Name.GetHashCode(); 212 | 213 | /// Table of interned symbols 214 | protected static readonly Dictionary Table = 215 | new Dictionary(); 216 | 217 | /// Return an interned symbol for the name. 218 | /// If the name is not interned yet, such a symbol 219 | /// will be constructed with . 220 | protected static Sym New(string name, Func make) { 221 | lock (Table) { 222 | if (! Table.TryGetValue(name, out Sym result)) { 223 | result = make(name); 224 | Table[name] = result; 225 | } 226 | return result; 227 | } 228 | } 229 | 230 | /// Construct an interned symbol. 231 | public static Sym New(string name) => New(name, s => new Sym(s)); 232 | 233 | /// Is it interned? 234 | public bool IsInterned { 235 | get { 236 | lock (Table) { 237 | return Table.TryGetValue(Name, out Sym s) && 238 | Object.ReferenceEquals(this, s); 239 | } 240 | } 241 | } 242 | } 243 | ``` 244 | 245 | Keywords of Lisp are defined as follows. 246 | 247 | ```CS 248 | // Expression keyword 249 | sealed class Keyword: Sym { 250 | Keyword(string name): base(name) {} 251 | internal static new Sym New(string name) 252 | => New(name, s => new Keyword(s)); 253 | } 254 | 255 | static readonly Sym CondSym = Keyword.New("cond"); 256 | static readonly Sym LambdaSym = Keyword.New("lambda"); 257 | static readonly Sym MacroSym = Keyword.New("macro"); 258 | static readonly Sym PrognSym = Keyword.New("progn"); 259 | static readonly Sym QuasiquoteSym = Keyword.New("quasiquote"); 260 | static readonly Sym QuoteSym = Keyword.New("quote"); 261 | static readonly Sym SetqSym = Keyword.New("setq"); 262 | ``` 263 | 264 | Now, if you call `Sym.New("cond")` in `ReadToken()`, 265 | you will get `CondSym`, an instance of the `Keyword` class. 266 | 267 | 268 | 269 | ## 3. Implementations of Lisp functions 270 | 271 | The `Interp` class implements the core of the Lisp interpreter. 272 | It has a map for global variables and standard out for built-in functions. 273 | 274 | ```CS 275 | /// Core of the Lisp interpreter 276 | public class Interp { 277 | /// Table of the global values of symbols 278 | protected readonly Dictionary Globals = 279 | new Dictionary(); 280 | 281 | /// Standard out 282 | public TextWriter COut { get; set; } = Console.Out; 283 | ``` 284 | 285 | Each built-in function is defined with the `Def` method below. 286 | The `carity` argument takes the arity of the function to be defined. 287 | If the function has `&rest`, the `carity` 288 | takes `-(`_number of fixed arguments_ ` + 1)`. 289 | 290 | ```CS 291 | /// Define a built-in function by a name, an arity, 292 | /// and a body. 293 | public void Def(string name, int carity, BuiltInFuncBody body) { 294 | Globals[Sym.New(name)] = new BuiltInFunc(name, carity, body); 295 | } 296 | ``` 297 | 298 | Below is an excerpt of the constructor of `Interp`. 299 | It shows the implementation of five elementary functions of Lisp. 300 | 301 | ```CS 302 | /// Set each built-in function/variable as the global value 303 | /// of symbol. 304 | public Interp() { 305 | Globals[TSym] = TSym; 306 | Def("car", 1, a => (a[0] as Cell)?.Car); 307 | Def("cdr", 1, a => (a[0] as Cell)?.Cdr); 308 | Def("cons", 2, a => new Cell(a[0], a[1])); 309 | Def("atom", 1, a => (a[0] is Cell) ? null : TSym); 310 | Def("eq", 2, a => (a[0] == a[1]) ? TSym : null); 311 | ``` 312 | 313 | The standard out `COut` is used as follows: 314 | 315 | ```CS 316 | Def("prin1", 1, a => { 317 | COut.Write(Str(a[0], true)); return a[0]; 318 | }); 319 | Def("princ", 1, a => { 320 | COut.Write(Str(a[0], false)); return a[0]; 321 | }); 322 | Def("terpri", 0, a => { 323 | COut.WriteLine(); return TSym; 324 | }); 325 | ``` 326 | 327 | The function `dump` takes no arguments and returns a list of all global 328 | variables. 329 | Internally it reads the keys from `Globals` and constructs a list of them. 330 | 331 | ```CS 332 | Def("dump", 0, a => 333 | Globals.Keys.Aggregate((Cell) null, (x, y) => new Cell(y, x))); 334 | ``` 335 | 336 | For an example of running `(dump)`, see [§1](#1). 337 | 338 | 339 | Several functions and macros of Lisp are defined in the initialization script 340 | `Prelude`, which runs in the task of `MakeInterp`. 341 | 342 | ```CS 343 | /// Make a Lisp interpreter initialized with Prelude. 344 | public static async Task MakeInterp() { 345 | var interp = new Interp(); 346 | await Run(interp, new StringReader(Prelude)); 347 | return interp; 348 | } 349 | ``` 350 | 351 | Below is the head of `Prelude`. 352 | 353 | ```CS 354 | /// Lisp initialization script 355 | public static readonly string Prelude = @" 356 | (setq defmacro 357 | (macro (name args &rest body) 358 | `(progn (setq ,name (macro ,args ,@body)) 359 | ',name))) 360 | 361 | (defmacro defun (name args &rest body) 362 | `(progn (setq ,name (lambda ,args ,@body)) 363 | ',name)) 364 | 365 | (defun caar (x) (car (car x))) 366 | (defun cadr (x) (car (cdr x))) 367 | (defun cdar (x) (cdr (car x))) 368 | (defun cddr (x) (cdr (cdr x))) 369 | ``` 370 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2017 OKI Software Co., Ltd. 2 | Copyright (c) 2018 SUZUKI Hisao 3 | 4 | Permission is hereby granted, free of charge, to any person obtaining a 5 | copy of this software and associated documentation files (the "Software"), 6 | to deal in the Software without restriction, including without limitation 7 | the rights to use, copy, modify, merge, publish, distribute, sublicense, 8 | and/or sell copies of the Software, and to permit persons to whom the 9 | Software is furnished to do so, subject to the following conditions: 10 | 11 | The above copyright notice and this permission notice shall be included in 12 | all copies or substantial portions of the Software. 13 | 14 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 15 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 16 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL 17 | THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 18 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING 19 | FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER 20 | DEALINGS IN THE SOFTWARE. 21 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Lisp in C# 7 2 | 3 | This is a Lisp interpreter compatible with 4 | [lisp-in-dart](https://github.com/nukata/lisp-in-dart) 5 | ~~except for numeric types: all numbers are `double` in C#~~. 6 | I wrote it in C# 6 and presented it under the MIT License at 7 | (broken link) 8 | until the spring of 2017 (H29). 9 | I slightly modified it to match C# 7 in 2018 (H30). 10 | 11 | Now in 2019 (R1), 12 | I implemented a mixed mode arithmetic of `int`, `double` and `BigInteger` 13 | in the same way as 14 | [little-scheme-in-cs](https://github.com/nukata/little-scheme-in-cs). 15 | 16 | 17 | 18 | The same as lisp-in-dart, [lisp-in-go](https://github.com/nukata/lisp-in-go) 19 | and [lisp-in-typescript](https://github.com/nukata/lisp-in-typescript), 20 | this is a Lisp-1 with tail call optimization 21 | and partially hygienic macros but being a subset of Common Lisp 22 | in a loose meaning. 23 | It is easy to write a nontrivial script which runs both in this and in 24 | Common Lisp (and also in Emacs Lisp). 25 | Examples are found in the [`examples`](examples) folder. 26 | 27 | See [IMPLEMENTATION-NOTES.md](IMPLEMENTATION-NOTES.md) for the implementation. 28 | 29 | 30 | ## How to run 31 | 32 | With [Mono](https://www.mono-project.com) 6.12.0: 33 | 34 | ``` 35 | $ csc -o -r:System.Numerics.dll lisp.cs arith.cs 36 | .... 37 | $ mono lisp.exe 38 | > (+ 5 6) 39 | 11 40 | > (exit 0) 41 | $ 42 | ``` 43 | 44 | With [.NET](https://github.com/dotnet/core) 6.0: 45 | 46 | ``` 47 | $ dotnet build -c Release 48 | .... 49 | $ ./bin/Release/net6.0/lisp 50 | > (+ 5 6) 51 | 11 52 | > (exit 0) 53 | $ 54 | ``` 55 | 56 | You can give it a file name of your Lisp script. 57 | If you put a "`-`" after the file name, it will 58 | begin an interactive session after running the file. 59 | 60 | ``` 61 | $ cat examples/fib15.l 62 | (defun fib (n) 63 | (if (< n 2) 64 | 1 65 | (+ (fib (- n 1)) 66 | (fib (- n 2))))) 67 | (print (fib 15)) 68 | $ mono lisp.exe examples/fib15.l - 69 | 987 70 | > (fib 0) 71 | 1 72 | > (fib 15) 73 | 987 74 | > (fib 16) 75 | 1597 76 | > (exit 0) 77 | $ 78 | ``` 79 | 80 | 81 | ## Examples 82 | 83 | There are five files ending with `.l` under the `examples` folder. 84 | These run also in Emacs Lisp and Common Lisp. 85 | 86 | - [`qsort.l`](examples/qsort.l) 87 | performs a quick sort. 88 | 89 | ``` 90 | $ mono lisp.exe examples/qsort.l 91 | (1 1 2 3 3 4 5 5 5 6 7 8 9 9 9) 92 | $ 93 | ``` 94 | 95 | ``` 96 | $ emacs -batch -l examples/qsort.l 97 | 98 | (1 1 2 3 3 4 5 5 5 6 7 8 9 9 9) 99 | $ 100 | ``` 101 | 102 | ``` 103 | $ clisp examples/qsort.l 104 | 105 | (1 1 2 3 3 4 5 5 5 6 7 8 9 9 9) 106 | $ 107 | ``` 108 | 109 | 110 | - [`fact100.l`](examples/fact100.l) 111 | calculates 100!. 112 | 113 | ``` 114 | $ mono lisp.exe examples/fact100.l 115 | 93326215443944152681699238856266700490715968264381621468592963895217599993229915 116 | 608941463976156518286253697920827223758251185210916864000000000000000000000000 117 | $ 118 | ``` 119 | 120 | - [`fib15.l`](examples/fib15.l) 121 | calculates Fibonacci for 15. 122 | 123 | - [`eval-fib15.l`](examples/eval-fib15.l) 124 | calculates Fibonacci for 15 on a meta-circular Lisp evaluator. 125 | 126 | - [`eval-eval-fib15.l`](examples/eval-eval-fib15.l) 127 | calculates Fibonacci for 15 on a meta-circular Lisp evaluator 128 | on a meta-circular Lisp evaluator. 129 | 130 | 131 | 132 | There is one more example: 133 | 134 | - [`interp_in_thread.cs`](examples/interp_in_thread.cs) 135 | runs a Lisp interpreter in another thread. 136 | You can embed an interpreter within your application in the same way. 137 | 138 | ``` 139 | $ cd examples 140 | $ csc -o -t:library -r:System.Numerics.dll ../lisp.cs ../arith.cs 141 | .... 142 | $ csc -r:lisp.dll interp_in_thread.cs 143 | ... 144 | $ mono interp_in_thread.exe 145 | => (1 . 2) 146 | Reiwa 147 | => Reiwa 148 | $ 149 | ``` 150 | 151 | The examples of `eval-fib15.l` and `eval-eval-fib15.l` are inspired 152 | by . 153 | 154 | 155 | 156 | ## Performance 157 | 158 | The following is a result of a benchmark test: the time to execute [`eval-eval-fib15.l`](examples/eval-eval-fib15.l). 159 | I used MacBook Pro (15-inch, 2016), 2.6GHz Core i7, 16GB 2133MHz LPDDR3, macOS Mojave 10.14.6. 160 | 161 | | Lisp | Compiled/Executed on | Executed in | Executes | Time [sec] | Rel. Speed | 162 | |:------------------------------------------------------------------------------|:----------------------------------------------------------------|:--------------|:------------|-----------:|------------:| 163 | | GNU CLISP 2.49 | | Mach-O | *.fas | 4.0 | 8.0 164 | | GNU Emacs Lisp 26.2 | | Mach-O | *.elc | 6.4 | 5.0 165 | | [l2lisp-in-java](https://github.com/nukata/l2lisp-in-java) 1.0.0-9.4 | [AdoptOpenJDK 11.0.5+10 HotSpot](http://adoptopenjdk.net/) | *.jar | source file | 12.8 | 2.5 166 | | GNU Emacs Lisp 26.2 | | Mach-O | source file | 16.2 | 2.0 167 | | [lisp-in-dart](https://github.com/nukata/lisp-in-dart) 1.0.1 | Dart VM 2.5.2 | snapshot | source file | 20.4 | 1.6 168 | | [lisp-in-dart](https://github.com/nukata/lisp-in-dart) 1.0.1 | /Dart VM 2.5.2 | source file | source file | 21.4 | 1.5 169 | | [lisp-in-typescript](https://github.com/nukata/lisp-in-typescript) 1.0.0-1.27 | TS 3.6.4/Node.js 12.12.0 | *.js (ESNEXT) | source file | 23.9 | 1.3 170 | | [lisp-in-typescript](https://github.com/nukata/lisp-in-typescript) 1.0.0-1.27 | TS 3.6.4/Node.js 12.12.0 | *.js (ES5) | source file | 25.4 | 1.3 171 | | lisp-in-cs 2.0.0 | .NET Core SDK 3.0.100 | *.dll (.NET) | source file | 31.8 | 1.0 172 | | [l2lisp-in-python](https://github.com/nukata/l2lisp-in-python) (7.2) | /PyPy 7.1.1(Python 3.6.1) | source file | source file | 37.8 | 0.8 173 | | [l2lisp-in-python](https://github.com/nukata/l2lisp-in-python) (7.2) | /PyPy 7.1.1(Python 2.7.13) | source file | source file | 41.7 | 0.8 174 | | lisp-in-cs 2.0.0 | Mono 6.4.0.198 | *.exe (.NET) | source file | 43.9 | 0.7 175 | | [lisp-in-go](https://github.com/nukata/lisp-in-go) 2.0.1 | Go 1.13.3/ | Mach-O | source file | 66.6 | 0.5 176 | | GNU CLISP 2.49 | | Mach-O | source file | 575.8 | 0.1 177 | | [l2lisp-in-python](https://github.com/nukata/l2lisp-in-python) (7.2) | /Python 3.7.4 | source file | source file | 1116.7 | 0.0 178 | 179 | I am sorry to say that the performance of this Lisp (lisp-in-cs) is rather mediocre. 180 | Note that l2lisp-in-java, lisp-in-dart, lisp-in-typescript, lisp-in-cs and lisp-in-go are all written in largely the same way; l2lisp-in-python is a little old-fashioned. 181 | Therefore, *roughly speaking*, their speeds shown above reflect those of their respective implementation languages: Java, Dart, TypeScript, C# and Go (and Python). 182 | 183 | -------------------------------------------------------------------------------- /arith.cs: -------------------------------------------------------------------------------- 1 | // A little arithmetic in C# 7, R01.07.14/R01.10.27 by SUZUKI Hisao 2 | // derived from arith.cs at https://github.com/nukata/little-scheme-in-cs 3 | using System; 4 | using System.Numerics; // This implies -r:System.Numerics.dll 5 | 6 | // test: csc -d:TEST -o -r:System.Numerics.dll arith.cs && mono arith.exe 7 | 8 | namespace LittleArith { 9 | 10 | /// Mixed mode arithmetic of int, double and BigInteger 11 | /// For values of other types, the methods of 12 | /// this class will throw ArgumentException. 13 | public static class Arith { 14 | 15 | /// Convert a long into an int or a BigInteger. 16 | private static object Normalize(long x) { 17 | int i = (int) x; 18 | // NB: ((i == x) ? i : (BigInteger) x) will be a BigInteger. 19 | if (i == x) { 20 | return i; 21 | } else { 22 | return (BigInteger) x; 23 | } 24 | } 25 | 26 | /// Convert a BigInteger into an int if possible. 27 | private static object Normalize(BigInteger x) { 28 | try { 29 | return (int) x; 30 | } catch (OverflowException) { 31 | return x; 32 | } 33 | } 34 | 35 | /// Return true if x is a number. 36 | public static bool IsNumber(object x) { 37 | return x is int || x is double || x is BigInteger; 38 | } 39 | 40 | /// x + y 41 | public static object Add(object x, object y) { 42 | switch (x) { 43 | case int a: 44 | switch (y) { 45 | case int b: 46 | return Normalize((long) a + (long) b); 47 | case double b: 48 | return a + b; 49 | case BigInteger b: 50 | return Normalize(a + b); 51 | } 52 | break; 53 | case double a: 54 | switch (y) { 55 | case int b: 56 | return a + b; 57 | case double b: 58 | return a + b; 59 | case BigInteger b: 60 | return a + (double) b; 61 | } 62 | break; 63 | case BigInteger a: 64 | switch (y) { 65 | case int b: 66 | return Normalize(a + b); 67 | case double b: 68 | return (double) a + b; 69 | case BigInteger b: 70 | return Normalize(a + b); 71 | } 72 | break; 73 | } 74 | throw new ArgumentException($"{x}, {y}"); 75 | } 76 | 77 | /// x - y 78 | public static object Subtract(object x, object y) { 79 | switch (x) { 80 | case int a: 81 | switch (y) { 82 | case int b: 83 | return Normalize((long) a - (long) b); 84 | case double b: 85 | return a - b; 86 | case BigInteger b: 87 | return Normalize(a - b); 88 | } 89 | break; 90 | case double a: 91 | switch (y) { 92 | case int b: 93 | return a - b; 94 | case double b: 95 | return a - b; 96 | case BigInteger b: 97 | return a - (double) b; 98 | } 99 | break; 100 | case BigInteger a: 101 | switch (y) { 102 | case int b: 103 | return Normalize(a - b); 104 | case double b: 105 | return (double) a - b; 106 | case BigInteger b: 107 | return Normalize(a - b); 108 | } 109 | break; 110 | } 111 | throw new ArgumentException($"{x}, {y}"); 112 | } 113 | 114 | /// x * y 115 | public static object Multiply(object x, object y) { 116 | switch (x) { 117 | case int a: 118 | switch (y) { 119 | case int b: 120 | return Normalize((long) a * (long) b); 121 | case double b: 122 | return a * b; 123 | case BigInteger b: 124 | return Normalize(a * b); 125 | } 126 | break; 127 | case double a: 128 | switch (y) { 129 | case int b: 130 | return a * b; 131 | case double b: 132 | return a * b; 133 | case BigInteger b: 134 | return a * (double) b; 135 | } 136 | break; 137 | case BigInteger a: 138 | switch (y) { 139 | case int b: 140 | return Normalize(a * b); 141 | case double b: 142 | return (double) a * b; 143 | case BigInteger b: 144 | return Normalize(a * b); 145 | } 146 | break; 147 | } 148 | throw new ArgumentException($"{x}, {y}"); 149 | } 150 | 151 | /// The rounded quotient of x and y. 152 | public static double RoundedQuotient(object x, object y) { 153 | switch (x) { 154 | case int a: 155 | switch (y) { 156 | case int b: 157 | return (double) a / (double) b; 158 | case double b: 159 | return (double) a / b; 160 | case BigInteger b: 161 | return (double) a / (double) b; 162 | } 163 | break; 164 | case double a: 165 | switch (y) { 166 | case int b: 167 | return a / (double) b; 168 | case double b: 169 | return a / b; 170 | case BigInteger b: 171 | return a / (double) b; 172 | } 173 | break; 174 | case BigInteger a: 175 | switch (y) { 176 | case int b: 177 | return (double) a / (double) b; 178 | case double b: 179 | return (double) a / b; 180 | case BigInteger b: 181 | return (double) a / (double) b; 182 | } 183 | break; 184 | } 185 | throw new ArgumentException($"{x}, {y}"); 186 | } 187 | 188 | private static object Truncate(double a) { 189 | BigInteger b = new BigInteger(a); 190 | return Normalize(b); 191 | } 192 | 193 | /// The quotient of x and y. 194 | public static object Quotient(object x, object y) { 195 | switch (x) { 196 | case int a: 197 | switch (y) { 198 | case int b: 199 | return a / b; 200 | case double b: 201 | return Truncate((double) a / b); 202 | case BigInteger b: 203 | return Normalize(a / b); 204 | } 205 | break; 206 | case double a: 207 | switch (y) { 208 | case int b: 209 | return Truncate(a / (double) b); 210 | case double b: 211 | return Truncate(a / b); 212 | case BigInteger b: 213 | return Truncate(a / (double) b); 214 | } 215 | break; 216 | case BigInteger a: 217 | switch (y) { 218 | case int b: 219 | return Normalize(a / b); 220 | case double b: 221 | return Truncate((double) a / b); 222 | case BigInteger b: 223 | return Normalize(a / b); 224 | } 225 | break; 226 | } 227 | throw new ArgumentException($"{x}, {y}"); 228 | } 229 | 230 | /// x % y 231 | public static object Remainder(object x, object y) { 232 | switch (x) { 233 | case int a: 234 | switch (y) { 235 | case int b: 236 | return a % b; 237 | case double b: 238 | return (double) a % b; 239 | case BigInteger b: 240 | return Normalize(a % b); 241 | } 242 | break; 243 | case double a: 244 | switch (y) { 245 | case int b: 246 | return a % (double) b; 247 | case double b: 248 | return a % b; 249 | case BigInteger b: 250 | return a % (double) b; 251 | } 252 | break; 253 | case BigInteger a: 254 | switch (y) { 255 | case int b: 256 | return Normalize(a % b); 257 | case double b: 258 | return (double) a % b; 259 | case BigInteger b: 260 | return Normalize(a % b); 261 | } 262 | break; 263 | } 264 | throw new ArgumentException($"{x}, {y}"); 265 | } 266 | 267 | /// Compare x and y. 268 | /// -1, 0 or 1 as x is less than, equal to, or greater than y. 269 | /// 270 | public static int Compare(object x, object y) { 271 | switch (x) { 272 | case int a: 273 | switch (y) { 274 | case int b: 275 | return Math.Sign((long) a - (long) b); 276 | case double b: 277 | return Math.Sign(a - b); 278 | case BigInteger b: 279 | return (a - b).Sign; 280 | } 281 | break; 282 | case double a: 283 | switch (y) { 284 | case int b: 285 | return Math.Sign(a - b); 286 | case double b: 287 | return Math.Sign(a - b); 288 | case BigInteger b: 289 | return Math.Sign(a - (double) b); 290 | } 291 | break; 292 | case BigInteger a: 293 | switch (y) { 294 | case int b: 295 | return (a - b).Sign; 296 | case double b: 297 | return Math.Sign((double) a - b); 298 | case BigInteger b: 299 | return (a - b).Sign; 300 | } 301 | break; 302 | } 303 | throw new ArgumentException($"{x}, {y}"); 304 | } 305 | 306 | /// Try to parse a string as an int, a BigInteger or a double. 307 | /// 308 | /// true if s was parsed successfully; otherwise, false. 309 | /// 310 | public static bool TryParse(string s, out object result) { 311 | if (int.TryParse(s, out int i)) { 312 | result = i; 313 | return true; 314 | } else if (BigInteger.TryParse(s, out BigInteger b)) { 315 | result = b; 316 | return true; 317 | } else if (double.TryParse(s, out double d)) { 318 | result = d; 319 | return true; 320 | } else { 321 | result = double.NaN; 322 | return false; 323 | } 324 | } 325 | 326 | #if TEST 327 | private static void Main() { 328 | object x = Normalize(3L); 329 | Console.WriteLine("{0}, {1}", x, x.GetType()); 330 | // -> 3, System.Int32 331 | x = Normalize(555_000_555_000); 332 | Console.WriteLine("{0}, {1}", x, x.GetType()); 333 | // -> 555000555000, System.Numerics.BigInteger 334 | 335 | x = Normalize((BigInteger) 3); 336 | Console.WriteLine("{0}, {1}", x, x.GetType()); 337 | // -> 3, System.Int32 338 | x = Normalize((BigInteger) 555_000_555_000); 339 | Console.WriteLine("{0}, {1}", x, x.GetType()); 340 | // -> 555000555000, System.Numerics.BigInteger 341 | 342 | try { 343 | x = Add("123", 4); 344 | } catch (ArgumentException ex) { 345 | Console.WriteLine(ex.Message); // -> 123, 4 346 | } 347 | x = Add(2, 7.89); 348 | Console.WriteLine("{0}, {1}", x, x.GetType()); 349 | // -> 9.89, System.Double 350 | x = Add(2, (BigInteger) 12345678901234567890); 351 | Console.WriteLine("{0}, {1}", x, x.GetType()); 352 | // -> 12345678901234567892, Sysmtem.Numerics.BigInteger 353 | x = Add((BigInteger) 12345678901234567890, 1.0); 354 | Console.WriteLine("{0}, {1}", x, x.GetType()); 355 | // -> 1.23456789012346E+19, Sysmtem.Double 356 | x = Add(1_000_111_000, 2_000_222_000); 357 | Console.WriteLine("{0}, {1}", x, x.GetType()); 358 | // -> 3000333000, Sysmtem.Numerics.BigInteger 359 | x = Add((BigInteger) 3_000_333_000, (BigInteger)(-2_000_222_000)); 360 | Console.WriteLine("{0}, {1}", x, x.GetType()); 361 | // -> 1000111000, Sysmtem.Int32 362 | 363 | x = Subtract((BigInteger)3_000_333_000, (BigInteger)2_000_222_000); 364 | Console.WriteLine("{0}, {1}", x, x.GetType()); 365 | // -> 1000111000, Sysmtem.Int32 366 | 367 | x = Multiply(2.2, (BigInteger) 3); 368 | Console.WriteLine("{0}, {1}", x, x.GetType()); 369 | // -> 6.6, Sysmtem.Double 370 | 371 | x = RoundedQuotient((BigInteger) 99, 3); 372 | Console.WriteLine("{0}, {1}", x, x.GetType()); 373 | // -> 33, System.Double 374 | 375 | x = Quotient((BigInteger) 99, 3); 376 | Console.WriteLine("{0}, {1}", x, x.GetType()); 377 | // -> 33, System.Int32 378 | x = Quotient(-99.9, 3); 379 | Console.WriteLine("{0}, {1}", x, x.GetType()); 380 | // -> -33, System.Int32 381 | 382 | x = Remainder(101.0, 3); 383 | Console.WriteLine("{0}, {1}", x, x.GetType()); 384 | // -> 2, System.Double 385 | x = Remainder((BigInteger) (-101), 3); 386 | Console.WriteLine("{0}, {1}", x, x.GetType()); 387 | // -> -2, System.Int32 388 | x = Remainder(-101.0, 3); 389 | Console.WriteLine("{0}, {1}", x, x.GetType()); 390 | // -> -2, System.Double 391 | 392 | Console.WriteLine("{0}", Compare(2.2, (BigInteger) 3)); 393 | // -> -1 394 | 395 | bool b = TryParse("123", out x); 396 | Console.WriteLine("{0}, {1}", x, x.GetType()); 397 | // -> 123, Sysmtem.Int32 398 | b = TryParse("123.4", out x); 399 | Console.WriteLine("{0}, {1}", x, x.GetType()); 400 | // -> 123.4, Sysmtem.Double 401 | b = TryParse("-12345678901234567890", out x); 402 | Console.WriteLine("{0}, {1}", x, x.GetType()); 403 | // -> -12345678901234567890, Sysmtem.Numerics.BigInteger 404 | } 405 | #endif 406 | } 407 | } 408 | -------------------------------------------------------------------------------- /examples/eval-eval-fib15.l: -------------------------------------------------------------------------------- 1 | ;;; A circular Lisp interpreter in Common/Emacs/Nukata Lisp 2 | ;;; by SUZUKI Hisao on H28.8/10, H29.3/13 3 | ;;; cf. Zick Standard Lisp (https://github.com/zick/ZickStandardLisp) 4 | 5 | (progn 6 | ;; Expr: (EXPR environment (symbol...) expression...) 7 | ;; Subr: (SUBR . function) 8 | ;; Environment: ((symbol . value)...) 9 | ;; N.B. Expr has its own environment since this Lisp is lexically scoped. 10 | 11 | ;; Language-specific Hacks 12 | (setq funcall (lambda (f x) (f x))) ; for Nukata Lisp and this Lisp 13 | (setq max-lisp-eval-depth 10000) ; for Emacs Lisp 14 | (setq max-specpdl-size 7000) ; for Emacs Lisp 15 | 16 | ;; The global environment of this Lisp 17 | (setq global-env 18 | (list '(*version* . (1.2 "Lisp" "circlisp")) 19 | (cons 'car 20 | (cons 'SUBR (lambda (x) (car (car x))))) 21 | (cons 'cdr 22 | (cons 'SUBR (lambda (x) (cdr (car x))))) 23 | (cons 'cons 24 | (cons 'SUBR (lambda (x) (cons (car x) (cadr% x))))) 25 | (cons 'eq 26 | (cons 'SUBR (lambda (x) (eq (car x) (cadr% x))))) 27 | (cons 'atom 28 | (cons 'SUBR (lambda (x) (atom (car x))))) 29 | (cons 'rplaca 30 | (cons 'SUBR (lambda (x) (rplaca (car x) (cadr% x))))) 31 | (cons 'rplacd 32 | (cons 'SUBR (lambda (x) (rplacd (car x) (cadr% x))))) 33 | (cons 'list 34 | (cons 'SUBR (lambda (x) x))) 35 | (cons '+ 36 | (cons 'SUBR (lambda (x) (+ (car x) (cadr% x))))) 37 | (cons '* 38 | (cons 'SUBR (lambda (x) (* (car x) (cadr% x))))) 39 | (cons '- 40 | (cons 'SUBR (lambda (x) (- (car x) (cadr% x))))) 41 | (cons 'truncate 42 | (cons 'SUBR (lambda (x) (truncate (car x) (cadr% x))))) 43 | (cons 'mod 44 | (cons 'SUBR (lambda (x) (mod (car x) (cadr% x))))) 45 | (cons '= 46 | (cons 'SUBR (lambda (x) (= (car x) (cadr% x))))) 47 | (cons '< 48 | (cons 'SUBR (lambda (x) (< (car x) (cadr% x))))) 49 | (cons 'print 50 | (cons 'SUBR (lambda (x) (print (car x))))) 51 | (cons 'apply 52 | (cons 'SUBR (lambda (x) (apply% (car x) (cadr% x))))) 53 | (cons 'eval 54 | (cons 'SUBR (lambda (x) (eval% (car x) global-env)))))) 55 | 56 | (defun caar% (x) (car (car x))) 57 | (defun cadr% (x) (car (cdr x))) 58 | (defun cddr% (x) (cdr (cdr x))) 59 | (defun caddr% (x) (car (cdr (cdr x)))) 60 | (defun cdddr% (x) (cdr (cdr (cdr x)))) 61 | (defun cadddr% (x) (car (cdr (cdr (cdr x))))) 62 | 63 | (defun assq% (key alist) ; cf. Emacs/Nukata Lisp 64 | (if alist 65 | (if (eq key (caar% alist)) 66 | (car alist) 67 | (assq% key (cdr alist))) 68 | nil)) 69 | 70 | (defun pairlis% (keys data alist) ; cf. Common Lisp 71 | (if keys 72 | (cons (cons (car keys) (car data)) 73 | (pairlis% (cdr keys) (cdr data) alist)) 74 | alist)) 75 | 76 | ;; Define symbol as value in the global environment. 77 | (defun global-def (sym val) 78 | (rplacd global-env 79 | (cons (car global-env) 80 | (cdr global-env))) 81 | (rplaca global-env 82 | (cons sym val))) 83 | 84 | (defun eval% (e env) 85 | (if (atom e) 86 | ((lambda (var) 87 | (if var 88 | (cdr var) 89 | e)) 90 | (assq% e env)) 91 | (if (eq (car e) 'quote) ; (quote e) 92 | (cadr% e) 93 | (if (eq (car e) 'if) ; (if e e e) 94 | (if (eval% (cadr% e) env) 95 | (eval% (caddr% e) env) 96 | (eval% (cadddr% e) env)) 97 | (if (eq (car e) 'progn) ; (progn e...) 98 | (eval-progn (cdr e) env nil) 99 | (if (eq (car e) 'lambda) ; (lambda (v...) e...) 100 | (make-closure env (cdr e)) 101 | (if (eq (car e) 'defun) ; (defun f (v...) e...) 102 | (global-def (cadr% e) 103 | (make-closure env (cddr% e))) 104 | (if (eq (car e) 'setq) ; (setq v e) 105 | ((lambda (var value) 106 | (if var 107 | (rplacd var value) 108 | (global-def (cadr% e) value)) 109 | value) 110 | (assq% (cadr% e) env) 111 | (eval% (caddr% e) env)) 112 | (apply% (eval% (car e) env) ; (f e...) 113 | (evlis (cdr e) env)))))))))) 114 | 115 | ;; (make-closure env '((v...) e...)) => (EXPR env (v...) e...) 116 | (defun make-closure (env ve) 117 | (cons 'EXPR 118 | (cons env ve))) 119 | 120 | ;; (eval-progn '((+ 1 2) 3 (+ 4 5)) global-env nil) => 9 121 | (defun eval-progn (x env result) 122 | (if x 123 | (if (cdr x) 124 | (eval-progn (cdr x) 125 | env 126 | (eval% (car x) env)) 127 | (eval% (car x) env)) 128 | result)) 129 | 130 | ;; (evlis '((+ 1 2) 3 (+ 4 5)) global-env) => (3 3 9) 131 | (defun evlis (x env) 132 | (if x 133 | (cons (eval% (car x) env) 134 | (evlis (cdr x) env)) 135 | nil)) 136 | 137 | (defun apply% (fun arg) 138 | (if (eq (car fun) 'EXPR) ; (EXPR env (v...) e...) 139 | (eval-progn (cdddr% fun) 140 | (pairlis% (caddr% fun) 141 | arg 142 | (cadr% fun)) 143 | nil) 144 | (if (eq (car fun) 'SUBR) ; (SUBR . f) 145 | (funcall (cdr fun) arg) 146 | fun))) 147 | 148 | (defun global-eval (e) 149 | (eval% e global-env)) 150 | 151 | (global-eval (quote 152 | 153 | ;; -- WRITE YOUR EXPRESSION HERE -- 154 | ;;; A circular Lisp interpreter in Common/Emacs/Nukata Lisp 155 | ;;; by SUZUKI Hisao on H28.8/10, H29.3/13 156 | ;;; cf. Zick Standard Lisp (https://github.com/zick/ZickStandardLisp) 157 | 158 | (progn 159 | ;; Expr: (EXPR environment (symbol...) expression...) 160 | ;; Subr: (SUBR . function) 161 | ;; Environment: ((symbol . value)...) 162 | ;; N.B. Expr has its own environment since this Lisp is lexically scoped. 163 | 164 | ;; Language-specific Hacks 165 | (setq funcall (lambda (f x) (f x))) ; for Nukata Lisp and this Lisp 166 | (setq max-lisp-eval-depth 10000) ; for Emacs Lisp 167 | (setq max-specpdl-size 7000) ; for Emacs Lisp 168 | 169 | ;; The global environment of this Lisp 170 | (setq global-env 171 | (list '(*version* . (1.2 "Lisp" "circlisp")) 172 | (cons 'car 173 | (cons 'SUBR (lambda (x) (car (car x))))) 174 | (cons 'cdr 175 | (cons 'SUBR (lambda (x) (cdr (car x))))) 176 | (cons 'cons 177 | (cons 'SUBR (lambda (x) (cons (car x) (cadr% x))))) 178 | (cons 'eq 179 | (cons 'SUBR (lambda (x) (eq (car x) (cadr% x))))) 180 | (cons 'atom 181 | (cons 'SUBR (lambda (x) (atom (car x))))) 182 | (cons 'rplaca 183 | (cons 'SUBR (lambda (x) (rplaca (car x) (cadr% x))))) 184 | (cons 'rplacd 185 | (cons 'SUBR (lambda (x) (rplacd (car x) (cadr% x))))) 186 | (cons 'list 187 | (cons 'SUBR (lambda (x) x))) 188 | (cons '+ 189 | (cons 'SUBR (lambda (x) (+ (car x) (cadr% x))))) 190 | (cons '* 191 | (cons 'SUBR (lambda (x) (* (car x) (cadr% x))))) 192 | (cons '- 193 | (cons 'SUBR (lambda (x) (- (car x) (cadr% x))))) 194 | (cons 'truncate 195 | (cons 'SUBR (lambda (x) (truncate (car x) (cadr% x))))) 196 | (cons 'mod 197 | (cons 'SUBR (lambda (x) (mod (car x) (cadr% x))))) 198 | (cons '= 199 | (cons 'SUBR (lambda (x) (= (car x) (cadr% x))))) 200 | (cons '< 201 | (cons 'SUBR (lambda (x) (< (car x) (cadr% x))))) 202 | (cons 'print 203 | (cons 'SUBR (lambda (x) (print (car x))))) 204 | (cons 'apply 205 | (cons 'SUBR (lambda (x) (apply% (car x) (cadr% x))))) 206 | (cons 'eval 207 | (cons 'SUBR (lambda (x) (eval% (car x) global-env)))))) 208 | 209 | (defun caar% (x) (car (car x))) 210 | (defun cadr% (x) (car (cdr x))) 211 | (defun cddr% (x) (cdr (cdr x))) 212 | (defun caddr% (x) (car (cdr (cdr x)))) 213 | (defun cdddr% (x) (cdr (cdr (cdr x)))) 214 | (defun cadddr% (x) (car (cdr (cdr (cdr x))))) 215 | 216 | (defun assq% (key alist) ; cf. Emacs/Nukata Lisp 217 | (if alist 218 | (if (eq key (caar% alist)) 219 | (car alist) 220 | (assq% key (cdr alist))) 221 | nil)) 222 | 223 | (defun pairlis% (keys data alist) ; cf. Common Lisp 224 | (if keys 225 | (cons (cons (car keys) (car data)) 226 | (pairlis% (cdr keys) (cdr data) alist)) 227 | alist)) 228 | 229 | ;; Define symbol as value in the global environment. 230 | (defun global-def (sym val) 231 | (rplacd global-env 232 | (cons (car global-env) 233 | (cdr global-env))) 234 | (rplaca global-env 235 | (cons sym val))) 236 | 237 | (defun eval% (e env) 238 | (if (atom e) 239 | ((lambda (var) 240 | (if var 241 | (cdr var) 242 | e)) 243 | (assq% e env)) 244 | (if (eq (car e) 'quote) ; (quote e) 245 | (cadr% e) 246 | (if (eq (car e) 'if) ; (if e e e) 247 | (if (eval% (cadr% e) env) 248 | (eval% (caddr% e) env) 249 | (eval% (cadddr% e) env)) 250 | (if (eq (car e) 'progn) ; (progn e...) 251 | (eval-progn (cdr e) env nil) 252 | (if (eq (car e) 'lambda) ; (lambda (v...) e...) 253 | (make-closure env (cdr e)) 254 | (if (eq (car e) 'defun) ; (defun f (v...) e...) 255 | (global-def (cadr% e) 256 | (make-closure env (cddr% e))) 257 | (if (eq (car e) 'setq) ; (setq v e) 258 | ((lambda (var value) 259 | (if var 260 | (rplacd var value) 261 | (global-def (cadr% e) value)) 262 | value) 263 | (assq% (cadr% e) env) 264 | (eval% (caddr% e) env)) 265 | (apply% (eval% (car e) env) ; (f e...) 266 | (evlis (cdr e) env)))))))))) 267 | 268 | ;; (make-closure env '((v...) e...)) => (EXPR env (v...) e...) 269 | (defun make-closure (env ve) 270 | (cons 'EXPR 271 | (cons env ve))) 272 | 273 | ;; (eval-progn '((+ 1 2) 3 (+ 4 5)) global-env nil) => 9 274 | (defun eval-progn (x env result) 275 | (if x 276 | (if (cdr x) 277 | (eval-progn (cdr x) 278 | env 279 | (eval% (car x) env)) 280 | (eval% (car x) env)) 281 | result)) 282 | 283 | ;; (evlis '((+ 1 2) 3 (+ 4 5)) global-env) => (3 3 9) 284 | (defun evlis (x env) 285 | (if x 286 | (cons (eval% (car x) env) 287 | (evlis (cdr x) env)) 288 | nil)) 289 | 290 | (defun apply% (fun arg) 291 | (if (eq (car fun) 'EXPR) ; (EXPR env (v...) e...) 292 | (eval-progn (cdddr% fun) 293 | (pairlis% (caddr% fun) 294 | arg 295 | (cadr% fun)) 296 | nil) 297 | (if (eq (car fun) 'SUBR) ; (SUBR . f) 298 | (funcall (cdr fun) arg) 299 | fun))) 300 | 301 | (defun global-eval (e) 302 | (eval% e global-env)) 303 | 304 | (global-eval (quote 305 | 306 | ;; -- WRITE YOUR EXPRESSION HERE -- 307 | (progn 308 | (defun fib (n) 309 | (if (< n 2) 310 | 1 311 | (+ (fib (- n 1)) 312 | (fib (- n 2))))) 313 | (print (fib 15))) 314 | ;; -------------------------------- 315 | ))) 316 | ;; -------------------------------- 317 | ))) 318 | -------------------------------------------------------------------------------- /examples/eval-fib15.l: -------------------------------------------------------------------------------- 1 | ;;; A circular Lisp interpreter in Common/Emacs/Nukata Lisp 2 | ;;; by SUZUKI Hisao on H28.8/10, H29.3/13 3 | ;;; cf. Zick Standard Lisp (https://github.com/zick/ZickStandardLisp) 4 | 5 | (progn 6 | ;; Expr: (EXPR environment (symbol...) expression...) 7 | ;; Subr: (SUBR . function) 8 | ;; Environment: ((symbol . value)...) 9 | ;; N.B. Expr has its own environment since this Lisp is lexically scoped. 10 | 11 | ;; Language-specific Hacks 12 | (setq funcall (lambda (f x) (f x))) ; for Nukata Lisp and this Lisp 13 | (setq max-lisp-eval-depth 10000) ; for Emacs Lisp 14 | (setq max-specpdl-size 7000) ; for Emacs Lisp 15 | 16 | ;; The global environment of this Lisp 17 | (setq global-env 18 | (list '(*version* . (1.2 "Lisp" "circlisp")) 19 | (cons 'car 20 | (cons 'SUBR (lambda (x) (car (car x))))) 21 | (cons 'cdr 22 | (cons 'SUBR (lambda (x) (cdr (car x))))) 23 | (cons 'cons 24 | (cons 'SUBR (lambda (x) (cons (car x) (cadr% x))))) 25 | (cons 'eq 26 | (cons 'SUBR (lambda (x) (eq (car x) (cadr% x))))) 27 | (cons 'atom 28 | (cons 'SUBR (lambda (x) (atom (car x))))) 29 | (cons 'rplaca 30 | (cons 'SUBR (lambda (x) (rplaca (car x) (cadr% x))))) 31 | (cons 'rplacd 32 | (cons 'SUBR (lambda (x) (rplacd (car x) (cadr% x))))) 33 | (cons 'list 34 | (cons 'SUBR (lambda (x) x))) 35 | (cons '+ 36 | (cons 'SUBR (lambda (x) (+ (car x) (cadr% x))))) 37 | (cons '* 38 | (cons 'SUBR (lambda (x) (* (car x) (cadr% x))))) 39 | (cons '- 40 | (cons 'SUBR (lambda (x) (- (car x) (cadr% x))))) 41 | (cons 'truncate 42 | (cons 'SUBR (lambda (x) (truncate (car x) (cadr% x))))) 43 | (cons 'mod 44 | (cons 'SUBR (lambda (x) (mod (car x) (cadr% x))))) 45 | (cons '= 46 | (cons 'SUBR (lambda (x) (= (car x) (cadr% x))))) 47 | (cons '< 48 | (cons 'SUBR (lambda (x) (< (car x) (cadr% x))))) 49 | (cons 'print 50 | (cons 'SUBR (lambda (x) (print (car x))))) 51 | (cons 'apply 52 | (cons 'SUBR (lambda (x) (apply% (car x) (cadr% x))))) 53 | (cons 'eval 54 | (cons 'SUBR (lambda (x) (eval% (car x) global-env)))))) 55 | 56 | (defun caar% (x) (car (car x))) 57 | (defun cadr% (x) (car (cdr x))) 58 | (defun cddr% (x) (cdr (cdr x))) 59 | (defun caddr% (x) (car (cdr (cdr x)))) 60 | (defun cdddr% (x) (cdr (cdr (cdr x)))) 61 | (defun cadddr% (x) (car (cdr (cdr (cdr x))))) 62 | 63 | (defun assq% (key alist) ; cf. Emacs/Nukata Lisp 64 | (if alist 65 | (if (eq key (caar% alist)) 66 | (car alist) 67 | (assq% key (cdr alist))) 68 | nil)) 69 | 70 | (defun pairlis% (keys data alist) ; cf. Common Lisp 71 | (if keys 72 | (cons (cons (car keys) (car data)) 73 | (pairlis% (cdr keys) (cdr data) alist)) 74 | alist)) 75 | 76 | ;; Define symbol as value in the global environment. 77 | (defun global-def (sym val) 78 | (rplacd global-env 79 | (cons (car global-env) 80 | (cdr global-env))) 81 | (rplaca global-env 82 | (cons sym val))) 83 | 84 | (defun eval% (e env) 85 | (if (atom e) 86 | ((lambda (var) 87 | (if var 88 | (cdr var) 89 | e)) 90 | (assq% e env)) 91 | (if (eq (car e) 'quote) ; (quote e) 92 | (cadr% e) 93 | (if (eq (car e) 'if) ; (if e e e) 94 | (if (eval% (cadr% e) env) 95 | (eval% (caddr% e) env) 96 | (eval% (cadddr% e) env)) 97 | (if (eq (car e) 'progn) ; (progn e...) 98 | (eval-progn (cdr e) env nil) 99 | (if (eq (car e) 'lambda) ; (lambda (v...) e...) 100 | (make-closure env (cdr e)) 101 | (if (eq (car e) 'defun) ; (defun f (v...) e...) 102 | (global-def (cadr% e) 103 | (make-closure env (cddr% e))) 104 | (if (eq (car e) 'setq) ; (setq v e) 105 | ((lambda (var value) 106 | (if var 107 | (rplacd var value) 108 | (global-def (cadr% e) value)) 109 | value) 110 | (assq% (cadr% e) env) 111 | (eval% (caddr% e) env)) 112 | (apply% (eval% (car e) env) ; (f e...) 113 | (evlis (cdr e) env)))))))))) 114 | 115 | ;; (make-closure env '((v...) e...)) => (EXPR env (v...) e...) 116 | (defun make-closure (env ve) 117 | (cons 'EXPR 118 | (cons env ve))) 119 | 120 | ;; (eval-progn '((+ 1 2) 3 (+ 4 5)) global-env nil) => 9 121 | (defun eval-progn (x env result) 122 | (if x 123 | (if (cdr x) 124 | (eval-progn (cdr x) 125 | env 126 | (eval% (car x) env)) 127 | (eval% (car x) env)) 128 | result)) 129 | 130 | ;; (evlis '((+ 1 2) 3 (+ 4 5)) global-env) => (3 3 9) 131 | (defun evlis (x env) 132 | (if x 133 | (cons (eval% (car x) env) 134 | (evlis (cdr x) env)) 135 | nil)) 136 | 137 | (defun apply% (fun arg) 138 | (if (eq (car fun) 'EXPR) ; (EXPR env (v...) e...) 139 | (eval-progn (cdddr% fun) 140 | (pairlis% (caddr% fun) 141 | arg 142 | (cadr% fun)) 143 | nil) 144 | (if (eq (car fun) 'SUBR) ; (SUBR . f) 145 | (funcall (cdr fun) arg) 146 | fun))) 147 | 148 | (defun global-eval (e) 149 | (eval% e global-env)) 150 | 151 | (global-eval (quote 152 | 153 | ;; -- WRITE YOUR EXPRESSION HERE -- 154 | (progn 155 | (defun fib (n) 156 | (if (< n 2) 157 | 1 158 | (+ (fib (- n 1)) 159 | (fib (- n 2))))) 160 | (print (fib 15))) 161 | ;; -------------------------------- 162 | ))) 163 | -------------------------------------------------------------------------------- /examples/fact100.l: -------------------------------------------------------------------------------- 1 | (defun factorial (n) 2 | (if (= n 0) 3 | 1 4 | (* n (factorial (- n 1))))) 5 | 6 | (print (factorial 100)) 7 | -------------------------------------------------------------------------------- /examples/fib15.l: -------------------------------------------------------------------------------- 1 | (defun fib (n) 2 | (if (< n 2) 3 | 1 4 | (+ (fib (- n 1)) 5 | (fib (- n 2))))) 6 | (print (fib 15)) 7 | -------------------------------------------------------------------------------- /examples/interp_in_thread.cs: -------------------------------------------------------------------------------- 1 | // An example of running Lisp in another thread 2 | using System; 3 | using System.Collections.Concurrent; 4 | using System.IO; 5 | using System.Text; 6 | using System.Threading; 7 | 8 | // csc -o -t:library -r:System.Numerics.dll ../lisp.cs ../arith.cs 9 | // csc -r:lisp.dll interp_in_thread.cs 10 | // mono interp_in_thread.exe 11 | 12 | // Expected output: 13 | // => (1 . 2) 14 | // Reiwa 15 | // => Reiwa 16 | 17 | public static class ThreadTest { 18 | 19 | // A simple substitute for Console.Out 20 | class SendOut: TextWriter { 21 | public BlockingCollection Queue 22 | = new BlockingCollection(); 23 | 24 | public override Encoding Encoding => Encoding.UTF8; 25 | public override void Write(char value) { 26 | Queue.Add(value); 27 | } 28 | } 29 | 30 | static readonly string EndSentinel = ":END"; 31 | 32 | // A Read-Eval-Send Loop in another thread 33 | static void RESLoop(SendOut so, BlockingCollection receiveIn) { 34 | var interp = NukataLisp.MakeInterp().Result; 35 | interp.COut = so; 36 | for (;;) { 37 | string s = receiveIn.Take(); 38 | if (s == EndSentinel) 39 | break; 40 | object x = NukataLisp.Run(interp, new StringReader(s)).Result; 41 | so.Queue.Add(x); 42 | so.Queue.Add(EndSentinel); 43 | } 44 | so.Queue.Add(EndSentinel); 45 | } 46 | 47 | // Run Lisp in another thread and send it S-expression strings. 48 | static void Main(string[] args) { 49 | SendOut so = new SendOut(); 50 | var queue = new BlockingCollection(); 51 | new Thread(() => RESLoop(so, queue)).Start(); 52 | foreach (string sExpression in new string[]{ 53 | "(cons 1 2)", 54 | "(print 'Reiwa)", 55 | EndSentinel 56 | }) { 57 | queue.Add(sExpression); 58 | for (;;) { 59 | object x = so.Queue.Take(); 60 | if (x is string s && s == EndSentinel) { 61 | break; 62 | } else if (x is char ch) { 63 | Console.Write(ch); 64 | } else { 65 | Console.WriteLine("=> {0}", x); 66 | } 67 | } 68 | } 69 | } 70 | } 71 | -------------------------------------------------------------------------------- /examples/qsort.l: -------------------------------------------------------------------------------- 1 | ;; quick sort for a sequence 2 | (defun qsort (seq) (_qsort seq nil)) 3 | 4 | (defun _qsort (left-seq right-sorted) 5 | (if (null left-seq) 6 | right-sorted 7 | (let ((pivot (car left-seq)) 8 | (tail (cdr left-seq))) 9 | (let ((pair (_split pivot tail))) 10 | (let ((left (car pair)) 11 | (right (cons pivot 12 | (_qsort (cadr pair) right-sorted)))) 13 | (_qsort left right)))))) 14 | 15 | (defun _split (pivot seq) ; => (left-seq right-seq) 16 | (if (null seq) 17 | (list nil nil) 18 | (let ((x (car seq)) 19 | (tail-pair (_split pivot (cdr seq)))) 20 | (if (< x pivot) 21 | (list (cons x (car tail-pair)) 22 | (cadr tail-pair)) 23 | (list (car tail-pair) 24 | (cons x (cadr tail-pair))))))) 25 | 26 | (print (qsort '(3 1 4 1 5 9 2 6 5 3 5 8 9 7 9))) 27 | ;; => (1 1 2 3 3 4 5 5 5 6 7 8 9 9 9) 28 | -------------------------------------------------------------------------------- /lisp.cs: -------------------------------------------------------------------------------- 1 | // H29.03.01/R01.10.27 by SUZUKI Hisao 2 | using System; 3 | using System.Collections.Generic; 4 | using System.Diagnostics; 5 | using System.IO; 6 | using System.Linq; 7 | using System.Reflection; 8 | using System.Text; 9 | using System.Text.RegularExpressions; 10 | using System.Threading.Tasks; 11 | using LittleArith; 12 | 13 | // lisp.exe: csc -doc:lisp.xml -o -r:System.Numerics.dll lisp.cs arith.cs 14 | // doc: mdoc update -i lisp.xml -o xml lisp.exe; mdoc export-html -o html xml 15 | 16 | [assembly: AssemblyProduct("Nukata Lisp")] 17 | [assembly: AssemblyVersion("2.0.0.*")] 18 | [assembly: AssemblyTitle("A Lisp interpreter in C# 7")] 19 | [assembly: AssemblyCopyright("© 2017 Oki Software Co., Ltd.; " + 20 | "© 2018 SUZUKI Hisao [MIT License]")] 21 | 22 | /// 23 | /// A Lisp interpreter written in C# 7 24 | /// 25 | /// This is ported from Nuka Lisp in Dart 26 | /// (https://github.com/nukata/lisp-in-dart). 27 | /// It is named after ex-Nukata Town in Japan. 28 | /// 29 | public static class NukataLisp { 30 | 31 | /// Cons cell 32 | public sealed class Cell { 33 | /// Head part of the cons cell 34 | public object Car; 35 | /// Tail part of the cons cell 36 | public object Cdr; 37 | 38 | /// Construct a cons cell with its head and tail. 39 | public Cell(object car, object cdr) { 40 | Car = car; 41 | Cdr = cdr; 42 | } 43 | 44 | /// Make a simple string representation. 45 | /// Do not invoke this for any circular list. 46 | public override string ToString() => 47 | $"({Car ?? "null"} . {Cdr ?? "null"})"; 48 | 49 | /// Length as a list 50 | public int Length => FoldL(0, this, (i, e) => i + 1); 51 | } 52 | 53 | 54 | // MapCar((a b c), fn) => (fn(a) fn(b) fn(c)) 55 | static Cell MapCar(Cell j, Func fn) { 56 | if (j == null) 57 | return null; 58 | object a = fn(j.Car); 59 | object d = j.Cdr; 60 | if (d is Cell dc) 61 | d = MapCar(dc, fn); 62 | if (j.Car == a && j.Cdr == d) 63 | return j; 64 | return new Cell(a, d); 65 | } 66 | 67 | // FoldL(x, (a b c), fn) => fn(fn(fn(x, a), b), c) 68 | static T FoldL (T x, Cell j, Func fn) { 69 | while (j != null) { 70 | x = fn(x, j.Car); 71 | j = (Cell) j.Cdr; 72 | } 73 | return x; 74 | } 75 | 76 | 77 | /// Lisp symbol 78 | public class Sym { 79 | /// The symbol's name 80 | public string Name { get; } 81 | 82 | /// Construct a symbol that is not interned. 83 | public Sym(string name) { 84 | Name = name; 85 | } 86 | 87 | /// Return the symbol's name 88 | public override string ToString() => Name; 89 | /// Return the hashcode of the symbol's name 90 | public override int GetHashCode() => Name.GetHashCode(); 91 | 92 | /// Table of interned symbols 93 | protected static readonly Dictionary Table = 94 | new Dictionary(); 95 | 96 | /// Return an interned symbol for the name. 97 | /// If the name is not interned yet, such a symbol 98 | /// will be constructed with . 99 | protected static Sym New(string name, Func make) { 100 | lock (Table) { 101 | if (! Table.TryGetValue(name, out Sym result)) { 102 | result = make(name); 103 | Table[name] = result; 104 | } 105 | return result; 106 | } 107 | } 108 | 109 | /// Construct an interned symbol. 110 | public static Sym New(string name) => New(name, s => new Sym(s)); 111 | 112 | /// Is it interned? 113 | public bool IsInterned { 114 | get { 115 | lock (Table) { 116 | return Table.TryGetValue(Name, out Sym s) && 117 | Object.ReferenceEquals(this, s); 118 | } 119 | } 120 | } 121 | } 122 | 123 | 124 | // Expression keyword 125 | sealed class Keyword: Sym { 126 | Keyword(string name): base(name) {} 127 | internal static new Sym New(string name) 128 | => New(name, s => new Keyword(s)); 129 | } 130 | 131 | static readonly Sym CondSym = Keyword.New("cond"); 132 | static readonly Sym LambdaSym = Keyword.New("lambda"); 133 | static readonly Sym MacroSym = Keyword.New("macro"); 134 | static readonly Sym PrognSym = Keyword.New("progn"); 135 | static readonly Sym QuasiquoteSym = Keyword.New("quasiquote"); 136 | static readonly Sym QuoteSym = Keyword.New("quote"); 137 | static readonly Sym SetqSym = Keyword.New("setq"); 138 | 139 | static readonly Sym BackQuoteSym = Sym.New("`"); 140 | static readonly Sym CommaAtSym = Sym.New(",@"); 141 | static readonly Sym CommaSym = Sym.New(","); 142 | static readonly Sym DotSym = Sym.New("."); 143 | static readonly Sym LeftParenSym = Sym.New("("); 144 | static readonly Sym RightParenSym = Sym.New(")"); 145 | static readonly Sym SingleQuoteSym = Sym.New("'"); 146 | 147 | static readonly Sym AppendSym = Sym.New("append"); 148 | static readonly Sym ConsSym = Sym.New("cons"); 149 | static readonly Sym ListSym = Sym.New("list"); 150 | static readonly Sym RestSym = Sym.New("&rest"); 151 | static readonly Sym UnquoteSym = Sym.New("unquote"); 152 | static readonly Sym UnquoteSplicingSym = Sym.New("unquote-splicing"); 153 | 154 | /// The symbol of t 155 | public static readonly Sym TSym = Sym.New("t"); 156 | 157 | 158 | //------------------------------------------------------------------ 159 | 160 | // Get cdr of list x as a Cell or null. 161 | static Cell CdrCell(Cell x) { 162 | var k = x.Cdr; 163 | if (k == null) { 164 | return null; 165 | } else { 166 | if (k is Cell c) 167 | return c; 168 | else 169 | throw new EvalException("proper list expected", x); 170 | } 171 | } 172 | 173 | 174 | /// Common base class of Lisp functions 175 | public abstract class LispFunc { 176 | /// Number of arguments, made negative if the function 177 | /// has &rest 178 | public int Carity { get; } 179 | 180 | int Arity => (Carity < 0) ? -Carity : Carity; 181 | bool HasRest => (Carity < 0); 182 | 183 | // Number of fixed arguments 184 | int FixedArgs => (Carity < 0) ? -Carity - 1 : Carity; 185 | 186 | /// Construct with Carity. 187 | protected LispFunc(int carity) { 188 | Carity = carity; 189 | } 190 | 191 | /// Make a frame for local variables from a list of 192 | /// actual arguments. 193 | public object[] MakeFrame(Cell arg) { 194 | var frame = new object[Arity]; 195 | int n = FixedArgs; 196 | int i; 197 | for (i = 0; i < n && arg != null; i++) { 198 | // Set the list of fixed arguments. 199 | frame[i] = arg.Car; 200 | arg = CdrCell(arg); 201 | } 202 | if (i != n || (arg != null && !HasRest)) 203 | throw new EvalException("arity not matched", this); 204 | if (HasRest) 205 | frame[n] = arg; 206 | return frame; 207 | } 208 | 209 | /// Evaluate each expression in a frame. 210 | public void EvalFrame(object[] frame, Interp interp, Cell env) { 211 | int n = FixedArgs; 212 | for (int i = 0; i < n; i++) 213 | frame[i] = interp.Eval(frame[i], env); 214 | if (HasRest) { 215 | if (frame[n] is Cell j) { 216 | Cell z = null; 217 | Cell y = null; 218 | do { 219 | var e = interp.Eval(j.Car, env); 220 | Cell x = new Cell(e, null); 221 | if (z == null) 222 | z = x; 223 | else 224 | y.Cdr = x; 225 | y = x; 226 | j = CdrCell(j); 227 | } while (j != null); 228 | frame[n] = z; 229 | } 230 | } 231 | } 232 | } 233 | 234 | 235 | // Common base class of functions which are defined with Lisp expressions 236 | abstract class DefinedFunc: LispFunc { 237 | // Lisp list as the function body 238 | public readonly Cell Body; 239 | 240 | protected DefinedFunc(int carity, Cell body): base(carity) { 241 | Body = body; 242 | } 243 | } 244 | 245 | 246 | // Common function type which represents any factory method of DefinedFunc 247 | delegate DefinedFunc FuncFactory(int carity, Cell body, Cell env); 248 | 249 | 250 | // Compiled macro expression 251 | sealed class Macro: DefinedFunc { 252 | Macro(int carity, Cell body): base(carity, body) {} 253 | public override string ToString() => $"#"; 254 | 255 | // Expand the macro with a list of actual arguments. 256 | public object ExpandWith(Interp interp, Cell arg) { 257 | object[] frame = MakeFrame(arg); 258 | Cell env = new Cell(frame, null); 259 | object x = null; 260 | for (Cell j = Body; j != null; j = CdrCell(j)) 261 | x = interp.Eval(j.Car, env); 262 | return x; 263 | } 264 | 265 | public static DefinedFunc Make(int carity, Cell body, Cell env) { 266 | Debug.Assert(env == null); 267 | return new Macro(carity, body); 268 | } 269 | } 270 | 271 | 272 | // Compiled lambda expression (Within another function) 273 | sealed class Lambda: DefinedFunc { 274 | Lambda(int carity, Cell body): base(carity, body) {} 275 | public override string ToString() => $"#"; 276 | 277 | public static DefinedFunc Make(int carity, Cell body, Cell env) { 278 | Debug.Assert(env == null); 279 | return new Lambda(carity, body); 280 | } 281 | } 282 | 283 | 284 | // Compiled lambda expression (Closure with environment) 285 | sealed class Closure: DefinedFunc { 286 | // The environment of the closure 287 | public readonly Cell Env; 288 | 289 | Closure(int carity, Cell body, Cell env): base(carity, body) { 290 | Env = env; 291 | } 292 | 293 | public Closure(Lambda x, Cell env): this(x.Carity, x.Body, env) {} 294 | 295 | public override string ToString() => 296 | $"#"; 297 | 298 | // Make an environment to evaluate the body from a list of actual args. 299 | public Cell MakeEnv(Interp interp, Cell arg, Cell interpEnv) { 300 | object[] frame = MakeFrame(arg); 301 | EvalFrame(frame, interp, interpEnv); 302 | return new Cell(frame, Env); // Prepend the frame to this Env. 303 | } 304 | 305 | public static DefinedFunc Make(int carity, Cell body, Cell env) => 306 | new Closure(carity, body, env); 307 | } 308 | 309 | 310 | /// Function type which represents any built-in function body 311 | /// 312 | public delegate object BuiltInFuncBody(object[] frame); 313 | 314 | /// Built-in function 315 | public sealed class BuiltInFunc: LispFunc { 316 | /// Name of this function 317 | public string Name { get; } 318 | /// C# function as the body of this function 319 | public BuiltInFuncBody Body { get; } 320 | 321 | /// Construct with Name, Carity and Body. 322 | public BuiltInFunc(string name, int carity, BuiltInFuncBody body) 323 | : base(carity) { 324 | Name = name; 325 | Body = body; 326 | } 327 | 328 | /// Return a string representation in Lisp. 329 | public override string ToString() => $"#<{Name}:{Carity}>"; 330 | 331 | /// Invoke the built-in function with a list of 332 | /// actual arguments. 333 | public object EvalWith(Interp interp, Cell arg, Cell interpEnv) { 334 | object[] frame = MakeFrame(arg); 335 | EvalFrame(frame, interp, interpEnv); 336 | try { 337 | return Body(frame); 338 | } catch (EvalException) { 339 | throw; 340 | } catch (Exception ex) { 341 | throw new EvalException($"{ex} -- {Name}", frame); 342 | } 343 | } 344 | } 345 | 346 | 347 | // Bound variable in a compiled lambda/macro expression 348 | sealed class Arg { 349 | public readonly int Level; 350 | public readonly int Offset; 351 | public readonly Sym Symbol; 352 | 353 | public Arg(int level, int offset, Sym symbol) { 354 | Level = level; 355 | Offset = offset; 356 | Symbol = symbol; 357 | } 358 | 359 | public override string ToString() => $"#{Level}:{Offset}:{Symbol}"; 360 | 361 | // Set a value x to the location corresponding to the variable in env. 362 | public void SetValue(object x, Cell env) { 363 | for (int i = 0; i < Level; i++) 364 | env = (Cell) env.Cdr; 365 | object[] frame = (object[]) env.Car; 366 | frame[Offset] = x; 367 | } 368 | 369 | // Get a value from the location corresponding to the variable in env. 370 | public object GetValue(Cell env) { 371 | for (int i = 0; i < Level; i++) 372 | env = (Cell) env.Cdr; 373 | object[] frame = (object[]) env.Car; 374 | return frame[Offset]; 375 | } 376 | } 377 | 378 | 379 | /// Exception in evaluation 380 | public class EvalException: Exception { 381 | /// Stack trace of Lisp evaluation 382 | public List Trace { get; } = new List(); 383 | 384 | /// Construct with a base message, cause, and 385 | /// a flag whether to quote strings in the cause. 386 | public EvalException(string msg, object x, bool quoteString=true) 387 | : base(msg + ": " + Str(x, quoteString)) {} 388 | 389 | /// Return a string representation which contains 390 | /// the message and the stack trace. 391 | public override string ToString() { 392 | var sb = new StringBuilder($"EvalException: {Message}", 0); 393 | foreach (string line in Trace) 394 | sb.Append($"\n\t{line}"); 395 | return sb.ToString(); 396 | } 397 | } 398 | 399 | 400 | // Exception which indicates on absense of a variable 401 | sealed class NotVariableException: EvalException { 402 | public NotVariableException(object x): base("variable expected", x) {} 403 | } 404 | 405 | 406 | //------------------------------------------------------------------ 407 | 408 | /// Core of the Lisp interpreter 409 | public class Interp { 410 | /// Table of the global values of symbols 411 | protected readonly Dictionary Globals = 412 | new Dictionary(); 413 | 414 | /// Standard out 415 | public TextWriter COut { get; set; } = Console.Out; 416 | 417 | /// Set each built-in function/variable as the global value 418 | /// of symbol. 419 | public Interp() { 420 | Globals[TSym] = TSym; 421 | Def("car", 1, a => (a[0] as Cell)?.Car); 422 | Def("cdr", 1, a => (a[0] as Cell)?.Cdr); 423 | Def("cons", 2, a => new Cell(a[0], a[1])); 424 | Def("atom", 1, a => (a[0] is Cell) ? null : TSym); 425 | Def("eq", 2, a => (a[0] == a[1]) ? TSym : null); 426 | 427 | Def("list", -1, a => a[0]); 428 | Def("rplaca", 2, a => { ((Cell) a[0]).Car = a[1]; return a[1]; }); 429 | Def("rplacd", 2, a => { ((Cell) a[0]).Cdr = a[1]; return a[1]; }); 430 | Def("length", 1, a => { 431 | dynamic x = a[0]; 432 | if (x == null) 433 | return 0; 434 | return x.Length; 435 | }); 436 | Def("stringp", 1, a => (a[0] is string) ? TSym : null); 437 | 438 | Def("numberp", 1, a => (Arith.IsNumber(a[0])) ? TSym : null); 439 | Def("eql", 2, a => { 440 | var x = a[0]; 441 | var y = a[1]; 442 | if (x == null) 443 | return (y == null) ? TSym : null; 444 | else if (x.Equals(y)) 445 | return TSym; 446 | else if (Arith.IsNumber(x) && Arith.IsNumber(y)) 447 | return (Arith.Compare(x, y) == 0) ? TSym : null; 448 | else 449 | return null; 450 | }); 451 | Def("<", 2, a => (Arith.Compare(a[0], a[1]) < 0) ? TSym : null); 452 | 453 | Def("%", 2, a => Arith.Remainder(a[0], a[1])); 454 | Def("mod", 2, a => { 455 | var x = a[0]; 456 | var y = a[1]; 457 | int xs = Arith.Compare(x, 0); 458 | int ys = Arith.Compare(y, 0); 459 | var q = Arith.Remainder(x, y); 460 | if ((xs < 0 && ys > 0) || (xs > 0 && ys < 0)) 461 | return Arith.Add(q, y); 462 | return q; 463 | }); 464 | 465 | Def("+", -1, a => FoldL((object) 0, (Cell) a[0], 466 | (i, j) => Arith.Add(i, j))); 467 | Def("*", -1, a => FoldL((object) 1, (Cell) a[0], 468 | (i, j) => Arith.Multiply(i, j))); 469 | Def("-", -2, a => { 470 | var x = a[0]; 471 | var y = (Cell) a[1]; 472 | if (y == null) 473 | return Arith.Subtract(0, x); 474 | return FoldL(x, y, (i, j) => Arith.Subtract(i, j)); 475 | }); 476 | Def("/", -3, a => FoldL(Arith.RoundedQuotient(a[0], a[1]), 477 | (Cell) a[2], 478 | (i, j) => Arith.RoundedQuotient(i, j))); 479 | Def("truncate", -2, a => { 480 | var x = a[0]; 481 | var y = (Cell) a[1]; 482 | if (y == null) 483 | return Arith.Quotient(x, 1); 484 | else if (y.Cdr == null) 485 | return Arith.Quotient(x, y.Car); 486 | else 487 | throw new ArgumentException 488 | ("one or two arguments expected"); 489 | }); 490 | 491 | Def("prin1", 1, a => { 492 | COut.Write(Str(a[0], true)); return a[0]; 493 | }); 494 | Def("princ", 1, a => { 495 | COut.Write(Str(a[0], false)); return a[0]; 496 | }); 497 | Def("terpri", 0, a => { 498 | COut.WriteLine(); return TSym; 499 | }); 500 | 501 | var gensymCounterSym = Sym.New("*gensym-counter*"); 502 | Globals[gensymCounterSym] = 1; 503 | Def("gensym", 0, a => { 504 | int x = (int) Globals[gensymCounterSym]; 505 | Globals[gensymCounterSym] = x + 1; 506 | return new Sym($"G{(int) x}"); 507 | }); 508 | 509 | Def("make-symbol", 1, a => new Sym((string) a[0])); 510 | Def("intern", 1, a => Sym.New((string) a[0])); 511 | Def("symbol-name", 1, a => ((Sym) a[0]).Name); 512 | 513 | Def("apply", 2, a => 514 | Eval(new Cell(a[0], MapCar((Cell) a[1], QqQuote)), null)); 515 | 516 | Def("exit", 1, a => { 517 | Environment.Exit((int) a[0]); 518 | return null; 519 | }); 520 | Def("dump", 0, a => 521 | Globals.Keys.Aggregate((Cell) null, (x, y) => new Cell(y, x))); 522 | 523 | var assembly = Assembly.GetExecutingAssembly(); 524 | var product = (AssemblyProductAttribute) 525 | Attribute.GetCustomAttribute 526 | (assembly, typeof(AssemblyProductAttribute)); 527 | var version = assembly.GetName().Version; 528 | double iversion = version.Major + 0.1 * version.Minor + 529 | 0.01 * version.Build; 530 | Globals[Sym.New("*version*")] = 531 | new Cell(iversion, 532 | new Cell("C# 7", new Cell(product.Product, null))); 533 | } 534 | 535 | /// Define a built-in function by a name, an arity, 536 | /// and a body. 537 | public void Def(string name, int carity, BuiltInFuncBody body) { 538 | Globals[Sym.New(name)] = new BuiltInFunc(name, carity, body); 539 | } 540 | 541 | /// Evaluate a Lisp expression in an environment. 542 | public object Eval(object x, Cell env) { 543 | try { 544 | for (;;) { 545 | switch (x) { 546 | case Arg xarg: 547 | return xarg.GetValue(env); 548 | case Sym xsym: 549 | try { 550 | return Globals[xsym]; 551 | } catch (KeyNotFoundException) { 552 | throw new EvalException("void variable", x); 553 | } 554 | case Cell xcell: 555 | var fn = xcell.Car; 556 | Cell arg = CdrCell(xcell); 557 | if (fn is Keyword) { 558 | if (fn == QuoteSym) { 559 | if (arg != null && arg.Cdr == null) 560 | return arg.Car; 561 | throw new EvalException("bad quote", x); 562 | } else if (fn == PrognSym) { 563 | x = EvalProgN(arg, env); 564 | } else if (fn == CondSym) { 565 | x = EvalCond(arg, env); 566 | } else if (fn == SetqSym) { 567 | return EvalSetQ(arg, env); 568 | } else if (fn == LambdaSym) { 569 | return Compile(arg, env, Closure.Make); 570 | } else if (fn == MacroSym) { 571 | if (env != null) 572 | throw new EvalException("nested macro", x); 573 | return Compile(arg, null, Macro.Make); 574 | } else if (fn == QuasiquoteSym) { 575 | if (arg != null && arg.Cdr == null) 576 | x = QqExpand(arg.Car); 577 | else 578 | throw new EvalException ("bad quasiquote", 579 | x); 580 | } else { 581 | throw new EvalException("bad keyword", fn); 582 | } 583 | } else { // Application of a function 584 | if (fn is Sym fnsym) { 585 | // Expand fn = Eval(fn, env) here for speed. 586 | try { 587 | fn = Globals[fnsym]; 588 | } catch (KeyNotFoundException) { 589 | throw new EvalException("undefined", 590 | fnsym); 591 | } 592 | } else { 593 | fn = Eval(fn, env); 594 | } 595 | switch (fn) { 596 | case Closure fnclosure: 597 | env = fnclosure.MakeEnv(this, arg, env); 598 | x = EvalProgN(fnclosure.Body, env); 599 | break; 600 | case Macro fnmacro: 601 | x = fnmacro.ExpandWith(this, arg); 602 | break; 603 | case BuiltInFunc fnbulitin: 604 | return fnbulitin.EvalWith(this, arg, env); 605 | default: 606 | throw new EvalException("not appliable", fn); 607 | } 608 | } 609 | break; 610 | case Lambda xlambda: 611 | return new Closure(xlambda, env); 612 | default: 613 | return x; // numbers, strings, null etc. 614 | } 615 | } 616 | } catch (EvalException ex) { 617 | if (ex.Trace.Count < 10) 618 | ex.Trace.Add(Str(x)); 619 | throw ex; 620 | } 621 | } 622 | 623 | // (progn E1 ... En) => Evaluate E1, ... except for En and return it. 624 | object EvalProgN(Cell j, Cell env) { 625 | if (j == null) 626 | return null; 627 | for (;;) { 628 | var x = j.Car; 629 | j = CdrCell(j); 630 | if (j == null) 631 | return x; // The tail expression to be evaluated later 632 | Eval(x, env); 633 | } 634 | } 635 | 636 | // Evaluate a conditional expression and return the selection. 637 | object EvalCond(Cell j, Cell env) { 638 | for (; j != null; j = CdrCell(j)) { 639 | var clause = j.Car; 640 | if (clause != null) { 641 | if (clause is Cell k) { 642 | var result = Eval(k.Car, env); 643 | if (result != null) { // If the condition holds 644 | Cell body = CdrCell(k); 645 | if (body == null) 646 | return QqQuote(result); 647 | else 648 | return EvalProgN(body, env); 649 | } 650 | } else { 651 | throw new EvalException("cond test expected", clause); 652 | } 653 | } 654 | } 655 | return null; // No clause holds. 656 | } 657 | 658 | // (setq V1 E1 ..) => Evaluate Ei and assign it to Vi; return the last. 659 | object EvalSetQ(Cell j, Cell env) { 660 | object result = null; 661 | for (; j != null; j = CdrCell(j)) { 662 | var lval = j.Car; 663 | if (lval == TSym) 664 | throw new EvalException("not assignable", lval); 665 | j = CdrCell(j); 666 | if (j == null) 667 | throw new EvalException("right value expected", lval); 668 | result = Eval(j.Car, env); 669 | switch (lval) { 670 | case Arg arg: 671 | arg.SetValue(result, env); 672 | break; 673 | case Sym sym when !(sym is Keyword): 674 | Globals[sym] = result; 675 | break; 676 | default: 677 | throw new NotVariableException(lval); 678 | } 679 | } 680 | return result; 681 | } 682 | 683 | // Compile a Lisp list (macro ...) or (lambda ...). 684 | DefinedFunc Compile(Cell arg, Cell env, FuncFactory make) { 685 | if (arg == null) 686 | throw new EvalException("arglist and body expected", arg); 687 | var table = new Dictionary(); 688 | bool hasRest = MakeArgTable(arg.Car, table); 689 | int arity = table.Count; 690 | Cell body = CdrCell(arg); 691 | body = ScanForArgs(body, table) as Cell; 692 | body = ExpandMacros(body, 20) as Cell; // Expand up to 20 nestings. 693 | body = CompileInners(body) as Cell; 694 | return make(hasRest ? -arity : arity, body, env); 695 | } 696 | 697 | // Expand macros and quasi-quotations in an expression. 698 | object ExpandMacros(object j, int count) { 699 | if ((j is Cell cell) && count > 0) { 700 | var k = cell.Car; 701 | if (k == QuoteSym || k == LambdaSym || k == MacroSym) { 702 | return cell; 703 | } else if (k == QuasiquoteSym) { 704 | Cell d = CdrCell(cell); 705 | if (d != null && d.Cdr == null) { 706 | var z = QqExpand(d.Car); 707 | return ExpandMacros(z, count); 708 | } 709 | throw new EvalException("bad quasiquote", cell); 710 | } else { 711 | if (k is Sym sym) 712 | k = Globals.ContainsKey(sym) ? Globals[sym] : null; 713 | if (k is Macro macro) { 714 | Cell d = CdrCell(cell); 715 | var z = macro.ExpandWith(this, d); 716 | return ExpandMacros(z, count - 1); 717 | } else { 718 | return MapCar(cell, x => ExpandMacros(x, count)); 719 | } 720 | } 721 | } else { 722 | return j; 723 | } 724 | } 725 | 726 | // Replace inner lambda-expressions with Lambda instances. 727 | object CompileInners(object j) { 728 | if (j is Cell cell) { 729 | var k = cell.Car; 730 | if (k == QuoteSym) { 731 | return cell; 732 | } else if (k == LambdaSym) { 733 | Cell d = CdrCell(cell); 734 | return Compile(d, null, Lambda.Make); 735 | } else if (k == MacroSym) { 736 | throw new EvalException("nested macro", cell); 737 | } else { 738 | return MapCar(cell, x => CompileInners(x)); 739 | } 740 | } else { 741 | return j; 742 | } 743 | } 744 | } 745 | 746 | 747 | //------------------------------------------------------------------ 748 | 749 | // Make an argument-table; return true if there is a rest argument. 750 | static bool MakeArgTable(object arg, IDictionary table) { 751 | if (arg == null) { 752 | return false; 753 | } else if (arg is Cell argcell) { 754 | int offset = 0; // offset value within the call-frame 755 | bool hasRest = false; 756 | for (; argcell != null; argcell = CdrCell(argcell)) { 757 | var j = argcell.Car; 758 | if (hasRest) 759 | throw new EvalException("2nd rest", j); 760 | if (j == RestSym) { // &rest var 761 | argcell = CdrCell(argcell); 762 | if (argcell == null) 763 | throw new NotVariableException(argcell); 764 | j = argcell.Car; 765 | if (j == RestSym) 766 | throw new NotVariableException(j); 767 | hasRest = true; 768 | } 769 | Sym sym = j as Sym; 770 | if (sym == null) { 771 | Arg jarg = j as Arg; 772 | if (jarg != null) 773 | sym = jarg.Symbol; 774 | else 775 | throw new NotVariableException(j); 776 | } 777 | if (sym == TSym) 778 | throw new EvalException("not assignable", sym); 779 | if (table.ContainsKey(sym)) 780 | throw new EvalException("duplicated argument name", sym); 781 | table[sym] = new Arg(0, offset, sym); 782 | offset++; 783 | } 784 | return hasRest; 785 | } else { 786 | throw new EvalException("arglist expected", arg); 787 | } 788 | } 789 | 790 | // Scan 'j' for formal arguments in 'table' and replace them with Args. 791 | // And scan 'j' for free Args not in 'table' and promote their levels. 792 | static object ScanForArgs(object j, IDictionary table) { 793 | switch (j) { 794 | case Sym sym: 795 | return ((table.TryGetValue(sym, out Arg a)) ? a : 796 | j); 797 | case Arg arg: 798 | return ((table.TryGetValue(arg.Symbol, out Arg k)) ? k : 799 | new Arg(arg.Level + 1, arg.Offset, arg.Symbol)); 800 | case Cell cell: 801 | if (cell.Car == QuoteSym) 802 | return j; 803 | else if (cell.Car == QuasiquoteSym) 804 | return new Cell(QuasiquoteSym, 805 | ScanForQQ(cell.Cdr, table, 0)); 806 | else 807 | return MapCar(cell, x => ScanForArgs(x, table)); 808 | default: 809 | return j; 810 | } 811 | } 812 | 813 | // Scan for quasi-quotes and ScanForArgs them depending on the nesting 814 | // level. 815 | static object ScanForQQ(object j, IDictionary table, int level) { 816 | if (j is Cell cell) { 817 | var car = cell.Car; 818 | var cdr = cell.Cdr; 819 | if (car == QuasiquoteSym) { 820 | return new Cell(car, ScanForQQ(cdr, table, level + 1)); 821 | } else if (car == UnquoteSym || car == UnquoteSplicingSym) { 822 | var d = ((level == 0) ? ScanForArgs(cdr, table) : 823 | ScanForQQ(cdr, table, level - 1)); 824 | if (d == cdr) 825 | return j; 826 | return new Cell(car, d); 827 | } else { 828 | return MapCar(cell, x => ScanForQQ(x, table, level)); 829 | } 830 | } else { 831 | return j; 832 | } 833 | } 834 | 835 | 836 | //------------------------------------------------------------------ 837 | // Quasi-Quotation 838 | 839 | /// Expand x of any quqsi-quotation `x into 840 | /// the equivalent S-expression. 841 | public static object QqExpand(object x) => 842 | QqExpand0(x, 0); // Begin with the nesting level 0. 843 | 844 | /// Quote x so that the result evaluates to x. 845 | /// 846 | public static object QqQuote(object x) => 847 | (x is Sym || x is Cell) ? new Cell(QuoteSym, new Cell(x, null)) : x; 848 | 849 | static object QqExpand0(object x, int level) { 850 | if (x is Cell cell) { 851 | if (cell.Car == UnquoteSym) { // ,a 852 | if (level == 0) 853 | return CdrCell(cell).Car; // ,a => a 854 | } 855 | Cell t = QqExpand1(cell, level); 856 | if ((t.Car is Cell k) && t.Cdr == null) { 857 | if (k.Car == ListSym || k.Car == ConsSym) 858 | return k; 859 | } 860 | return new Cell(AppendSym, t); 861 | } else { 862 | return QqQuote(x); 863 | } 864 | } 865 | 866 | // Expand x of `x so that the result can be used as an argument of append. 867 | // Example 1: (,a b) => h=(list a) t=((list 'b)) => ((list a 'b)) 868 | // Example 2: (,a ,@(cons 2 3)) => h=(list a) t=((cons 2 3)) 869 | // => ((cons a (cons 2 3))) 870 | static Cell QqExpand1(object x, int level) { 871 | if (x is Cell cell) { 872 | if (cell.Car == UnquoteSym) { // ,a 873 | if (level == 0) 874 | return CdrCell(cell); // ,a => (a) 875 | level--; 876 | } else if (cell.Car == QuasiquoteSym) { // `a 877 | level++; 878 | } 879 | var h = QqExpand2(cell.Car, level); 880 | Cell t = QqExpand1(cell.Cdr, level); // != null 881 | if (t.Car == null && t.Cdr == null) { 882 | return new Cell(h, null); 883 | } else if (h is Cell hcell) { 884 | if (hcell.Car == ListSym) { 885 | if (t.Car is Cell tcar) { 886 | if (tcar.Car == ListSym) { 887 | var hh = QqConcat(hcell, tcar.Cdr); 888 | return new Cell(hh, t.Cdr); 889 | } 890 | } 891 | if (hcell.Cdr != null) { 892 | var hh = QqConsCons(CdrCell(hcell), t.Car); 893 | return new Cell(hh, t.Cdr); 894 | } 895 | } 896 | } 897 | return new Cell(h, t); 898 | } else { 899 | return new Cell(QqQuote(x), null); 900 | } 901 | } 902 | 903 | // (1 2), (3 4) => (1 2 3 4) 904 | static object QqConcat(Cell x, object y) => 905 | (x == null) ? y : 906 | new Cell(x.Car, QqConcat(CdrCell(x), y)); 907 | 908 | // (1 2 3), "a" => (cons 1 (cons 2 (cons 3 "a"))) 909 | static object QqConsCons(Cell x, object y) => 910 | (x == null) ? y : 911 | new Cell(ConsSym, 912 | new Cell(x.Car, 913 | new Cell(QqConsCons(CdrCell(x), y), null))); 914 | 915 | // Expand x.car of `x so that the result can be used as an arg of append. 916 | // Example: ,a => (list a); ,@(foo 1 2) => (foo 1 2); b => (list 'b) 917 | static object QqExpand2(object y, int level) { // Let y be x.car. 918 | if (y is Cell cell) { 919 | if (cell.Car == UnquoteSym) { // ,a 920 | if (level == 0) 921 | return new Cell(ListSym, cell.Cdr); // ,a => (list a) 922 | level--; 923 | } else if (cell.Car == UnquoteSplicingSym) { // ,@a 924 | if (level == 0) 925 | return CdrCell(cell).Car; // ,@a => a 926 | level--; 927 | } else if (cell.Car == QuasiquoteSym) { // `a 928 | level++; 929 | } 930 | } 931 | return new Cell(ListSym, new Cell(QqExpand0(y, level), null)); 932 | } 933 | 934 | 935 | //------------------------------------------------------------------ 936 | 937 | /// Reader of Lisp expressions 938 | public class Reader { 939 | readonly TextReader TReader; 940 | object Token; 941 | IEnumerator Tokens = 942 | ((IEnumerable) new string[0]).GetEnumerator(); 943 | int LineNo = 0; 944 | string Line = ""; 945 | bool Erred = false; 946 | 947 | /// Token of "End Of File" 948 | public static object EOF = new Sym("#EOF"); 949 | 950 | /// Construct a Lisp reader. 951 | /// Text reader from which Lisp expressions will 952 | /// be read 953 | public Reader(TextReader tr) { 954 | TReader = tr; 955 | } 956 | 957 | /// Read a Lisp expression and return it. 958 | /// Return EOF if the input runs out. 959 | public async Task Read() { 960 | try { 961 | await ReadToken(); 962 | return await ParseExpression(); 963 | } catch (FormatException ex) { 964 | throw new EvalException("syntax error", 965 | $"{ex.Message} -- {LineNo}: {Line}", 966 | false); 967 | } 968 | } 969 | 970 | async Task ParseExpression() { 971 | if (Token == LeftParenSym) { // (a b c) 972 | await ReadToken(); 973 | return await ParseListBody(); 974 | } else if (Token == SingleQuoteSym) { // 'a => (quote a) 975 | await ReadToken(); 976 | return new Cell(QuoteSym, 977 | new Cell(await ParseExpression(), null)); 978 | } else if (Token == BackQuoteSym) { // `a => (quasiquote a) 979 | await ReadToken(); 980 | return new Cell(QuasiquoteSym, 981 | new Cell(await ParseExpression(), null)); 982 | } else if (Token == CommaSym) { // ,a => (unquote a) 983 | await ReadToken(); 984 | return new Cell(UnquoteSym, 985 | new Cell(await ParseExpression(), null)); 986 | } else if (Token == CommaAtSym) { // ,@a => (unquote-splicing a) 987 | await ReadToken(); 988 | return new Cell(UnquoteSplicingSym, 989 | new Cell(await ParseExpression(), null)); 990 | } else if (Token == DotSym || Token == RightParenSym) { 991 | throw new FormatException($"unexpected {Token}"); 992 | } else { 993 | return Token; 994 | } 995 | } 996 | 997 | async Task ParseListBody() { 998 | if (Token == EOF) { 999 | throw new FormatException("unexpected EOF"); 1000 | } else if (Token == RightParenSym) { 1001 | return null; 1002 | } else { 1003 | var e1 = await ParseExpression(); 1004 | await ReadToken(); 1005 | object e2; 1006 | if (Token == DotSym) { // (a . b) 1007 | await ReadToken(); 1008 | e2 = await ParseExpression(); 1009 | await ReadToken(); 1010 | if (Token != RightParenSym) 1011 | throw new FormatException($"\")\" expected: {Token}"); 1012 | } else { 1013 | e2 = await ParseListBody(); 1014 | } 1015 | return new Cell(e1, e2); 1016 | } 1017 | } 1018 | 1019 | // Read the next token and set it to Token. 1020 | async Task ReadToken() { 1021 | while (!Tokens.MoveNext() || Erred) { // line ends or erred 1022 | Erred = false; 1023 | LineNo++; 1024 | Line = await TReader.ReadLineAsync(); 1025 | if (Line == null) { 1026 | Token = EOF; 1027 | return; 1028 | } 1029 | Tokens = ToTypedMatches(TokenPat.Matches(Line)) 1030 | .Select((Match m) => m.Groups[1].Value) 1031 | .Where((string s) => s != "") 1032 | .GetEnumerator(); 1033 | } 1034 | string t = Tokens.Current; 1035 | if (t[0] == '"') { 1036 | int n = t.Length - 1; 1037 | if (n < 1 || t[n] != '"') 1038 | throw new FormatException($"bad string: {t}"); 1039 | t = t.Substring(1, n - 1); 1040 | t = EscapePat.Replace(t, (Match m) => { 1041 | String key = m.Groups[1].Value; 1042 | return (Escapes.ContainsKey(key) ? Escapes[key] : 1043 | $"\\{key}"); 1044 | }); 1045 | Token = t; 1046 | return; 1047 | } 1048 | if (Arith.TryParse(t, out object num)) 1049 | Token = num; 1050 | else if (t == "nil") 1051 | Token = null; 1052 | else 1053 | Token = Sym.New(t); 1054 | } 1055 | } 1056 | 1057 | static IEnumerable ToTypedMatches(MatchCollection matches) { 1058 | foreach (Match match in matches) { 1059 | yield return match; 1060 | } 1061 | } 1062 | 1063 | // Regular expression to split a line into Lisp tokens 1064 | static readonly Regex TokenPat = 1065 | new Regex(@"\s+|;.*$|(""(\\.?|.)*?""|,@?|[^()'`~""; \t]+|.)"); 1066 | 1067 | // Regular expression to take an escape sequence out of a string 1068 | static readonly Regex EscapePat = new Regex(@"\\(.)"); 1069 | 1070 | // Mapping from a character of escape sequence to its string value 1071 | static readonly Dictionary Escapes = 1072 | new Dictionary { 1073 | ["\\"] = "\\", 1074 | ["\""] = "\"", 1075 | ["n"] = "\n", 1076 | ["r"] = "\r", 1077 | ["f"] = "\f", 1078 | ["b"] = "\b", 1079 | ["t"] = "\t", 1080 | ["v"] = "\v" 1081 | }; 1082 | 1083 | 1084 | //------------------------------------------------------------------ 1085 | 1086 | /// Make a string representation of Lisp expression. 1087 | /// Lisp expression 1088 | /// flag whether to quote string 1089 | public static string Str(object x, bool quoteString=true) { 1090 | // 4 is the threshold of ellipsis for circular lists 1091 | return Str4(x, quoteString, 4, null); 1092 | } 1093 | 1094 | // Mapping from a quote symbol to its string representation 1095 | static readonly Dictionary Quotes = 1096 | new Dictionary { 1097 | [QuoteSym] = "'", 1098 | [QuasiquoteSym] = "`", 1099 | [UnquoteSym] = ",", 1100 | [UnquoteSplicingSym] = ",@" 1101 | }; 1102 | 1103 | static string Str4(object x, bool quoteString, int count, 1104 | HashSet printed) { 1105 | switch (x) { 1106 | case null: 1107 | return "nil"; 1108 | case Cell cell: 1109 | if ((cell.Car is Sym csym) && Quotes.ContainsKey(csym)) { 1110 | if ((cell.Cdr is Cell xcdr) && xcdr.Cdr == null) 1111 | return Quotes[csym] 1112 | + Str4(xcdr.Car, true, count, printed); 1113 | } 1114 | return "(" + StrListBody(cell, count, printed) + ")"; 1115 | case string st: 1116 | if (! quoteString) 1117 | return st; 1118 | var bf = new StringBuilder(); 1119 | bf.Append('"'); 1120 | foreach (char ch in st) { 1121 | switch (ch) { 1122 | case '\b': bf.Append(@"\b"); break; 1123 | case '\t': bf.Append(@"\t"); break; 1124 | case '\n': bf.Append(@"\n"); break; 1125 | case '\v': bf.Append(@"\v"); break; 1126 | case '\f': bf.Append(@"\f"); break; 1127 | case '\r': bf.Append(@"\r"); break; 1128 | case '"': bf.Append("\\\""); break; 1129 | case '\\': bf.Append(@"\\"); break; 1130 | default: bf.Append(ch); break; 1131 | } 1132 | } 1133 | bf.Append('"'); 1134 | return bf.ToString(); 1135 | case Sym sym: 1136 | return (sym.IsInterned) ? sym.Name : $"#:{x}"; 1137 | case double d: // 123.0 => "123.0" 1138 | string lds = ((long) d).ToString(); 1139 | if (lds == d.ToString()) 1140 | return lds + ".0"; 1141 | break; 1142 | } 1143 | return x.ToString(); 1144 | } 1145 | 1146 | // Make a string representation of list omitting its "(" and ")". 1147 | static string StrListBody(Cell x, int count, HashSet printed) { 1148 | if (printed == null) 1149 | printed = new HashSet(); 1150 | var s = new List(); 1151 | object y; 1152 | for (y = x; y is Cell cell; y = cell.Cdr) { 1153 | if (printed.Add(cell)) { 1154 | count = 4; 1155 | } else { 1156 | count--; 1157 | if (count < 0) { 1158 | s.Add("..."); // an ellipsis for a circular list 1159 | return String.Join(" ", s); 1160 | } 1161 | } 1162 | s.Add(Str4(cell.Car, true, count, printed)); 1163 | } 1164 | if (y != null) { 1165 | s.Add("."); 1166 | s.Add(Str4(y, true, count, printed)); 1167 | } 1168 | for (y = x; y is Cell cell; y = cell.Cdr) 1169 | printed.Remove(cell); 1170 | return String.Join(" ", s); 1171 | } 1172 | 1173 | 1174 | //------------------------------------------------------------------ 1175 | 1176 | /// Run Read-Eval-Print Loop. 1177 | /// Exceptions are handled here and not thrown. 1178 | public static async Task RunREPL(Interp interp, TextReader input = null) { 1179 | if (input == null) 1180 | input = Console.In; 1181 | var reader = new Reader(input); 1182 | for (;;) { 1183 | interp.COut.Write("> "); 1184 | try { 1185 | var sExp = await reader.Read(); 1186 | if (sExp == Reader.EOF) 1187 | return; 1188 | var x = interp.Eval(sExp, null); 1189 | interp.COut.WriteLine(Str(x)); 1190 | } catch (Exception ex) { 1191 | interp.COut.WriteLine(ex); 1192 | } 1193 | } 1194 | } 1195 | 1196 | /// Run Read-Eval Loop. 1197 | public static async Task Run(Interp interp, TextReader input) { 1198 | var reader = new Reader(input); 1199 | object lastResult = Reader.EOF; 1200 | for (;;) { 1201 | var sExp = await reader.Read(); 1202 | if (sExp == Reader.EOF) 1203 | return lastResult; 1204 | lastResult = interp.Eval(sExp, null); 1205 | } 1206 | } 1207 | 1208 | /// Make a Lisp interpreter initialized with Prelude. 1209 | public static async Task MakeInterp() { 1210 | var interp = new Interp(); 1211 | await Run(interp, new StringReader(Prelude)); 1212 | return interp; 1213 | } 1214 | 1215 | static int Main(string[] args) { 1216 | var interp = MakeInterp().Result; 1217 | if (args.Length == 0) { 1218 | args = new string[] {"-"}; 1219 | } 1220 | foreach (var fileName in args) { 1221 | if (fileName == "-") { 1222 | RunREPL(interp).Wait(); 1223 | interp.COut.WriteLine("Goodbye"); 1224 | } else { 1225 | var input = new StreamReader(fileName); 1226 | Run(interp, input).Wait(); 1227 | } 1228 | } 1229 | return 0; 1230 | } 1231 | 1232 | 1233 | /// Lisp initialization script 1234 | public static readonly string Prelude = @" 1235 | (setq defmacro 1236 | (macro (name args &rest body) 1237 | `(progn (setq ,name (macro ,args ,@body)) 1238 | ',name))) 1239 | 1240 | (defmacro defun (name args &rest body) 1241 | `(progn (setq ,name (lambda ,args ,@body)) 1242 | ',name)) 1243 | 1244 | (defun caar (x) (car (car x))) 1245 | (defun cadr (x) (car (cdr x))) 1246 | (defun cdar (x) (cdr (car x))) 1247 | (defun cddr (x) (cdr (cdr x))) 1248 | (defun caaar (x) (car (car (car x)))) 1249 | (defun caadr (x) (car (car (cdr x)))) 1250 | (defun cadar (x) (car (cdr (car x)))) 1251 | (defun caddr (x) (car (cdr (cdr x)))) 1252 | (defun cdaar (x) (cdr (car (car x)))) 1253 | (defun cdadr (x) (cdr (car (cdr x)))) 1254 | (defun cddar (x) (cdr (cdr (car x)))) 1255 | (defun cdddr (x) (cdr (cdr (cdr x)))) 1256 | (defun not (x) (eq x nil)) 1257 | (defun consp (x) (not (atom x))) 1258 | (defun print (x) (prin1 x) (terpri) x) 1259 | (defun identity (x) x) 1260 | 1261 | (setq 1262 | = eql 1263 | null not 1264 | setcar rplaca 1265 | setcdr rplacd) 1266 | 1267 | (defun > (x y) (< y x)) 1268 | (defun >= (x y) (not (< x y))) 1269 | (defun <= (x y) (not (< y x))) 1270 | (defun /= (x y) (not (= x y))) 1271 | 1272 | (defun equal (x y) 1273 | (cond ((atom x) (eql x y)) 1274 | ((atom y) nil) 1275 | ((equal (car x) (car y)) (equal (cdr x) (cdr y))))) 1276 | 1277 | (defmacro if (test then &rest else) 1278 | `(cond (,test ,then) 1279 | ,@(cond (else `((t ,@else)))))) 1280 | 1281 | (defmacro when (test &rest body) 1282 | `(cond (,test ,@body))) 1283 | 1284 | (defmacro let (args &rest body) 1285 | ((lambda (vars vals) 1286 | (defun vars (x) 1287 | (cond (x (cons (if (atom (car x)) 1288 | (car x) 1289 | (caar x)) 1290 | (vars (cdr x)))))) 1291 | (defun vals (x) 1292 | (cond (x (cons (if (atom (car x)) 1293 | nil 1294 | (cadar x)) 1295 | (vals (cdr x)))))) 1296 | `((lambda ,(vars args) ,@body) ,@(vals args))) 1297 | nil nil)) 1298 | 1299 | (defmacro letrec (args &rest body) ; (letrec ((v e) ...) body...) 1300 | (let (vars setqs) 1301 | (defun vars (x) 1302 | (cond (x (cons (caar x) 1303 | (vars (cdr x)))))) 1304 | (defun sets (x) 1305 | (cond (x (cons `(setq ,(caar x) ,(cadar x)) 1306 | (sets (cdr x)))))) 1307 | `(let ,(vars args) ,@(sets args) ,@body))) 1308 | 1309 | (defun _append (x y) 1310 | (if (null x) 1311 | y 1312 | (cons (car x) (_append (cdr x) y)))) 1313 | (defmacro append (x &rest y) 1314 | (if (null y) 1315 | x 1316 | `(_append ,x (append ,@y)))) 1317 | 1318 | (defmacro and (x &rest y) 1319 | (if (null y) 1320 | x 1321 | `(cond (,x (and ,@y))))) 1322 | 1323 | (defun mapcar (f x) 1324 | (and x (cons (f (car x)) (mapcar f (cdr x))))) 1325 | 1326 | (defmacro or (x &rest y) 1327 | (if (null y) 1328 | x 1329 | `(cond (,x) 1330 | ((or ,@y))))) 1331 | 1332 | (defun listp (x) 1333 | (or (null x) (consp x))) ; NB (listp (lambda (x) (+ x 1))) => nil 1334 | 1335 | (defun memq (key x) 1336 | (cond ((null x) nil) 1337 | ((eq key (car x)) x) 1338 | (t (memq key (cdr x))))) 1339 | 1340 | (defun member (key x) 1341 | (cond ((null x) nil) 1342 | ((equal key (car x)) x) 1343 | (t (member key (cdr x))))) 1344 | 1345 | (defun assq (key alist) 1346 | (cond (alist (let ((e (car alist))) 1347 | (if (and (consp e) (eq key (car e))) 1348 | e 1349 | (assq key (cdr alist))))))) 1350 | 1351 | (defun assoc (key alist) 1352 | (cond (alist (let ((e (car alist))) 1353 | (if (and (consp e) (equal key (car e))) 1354 | e 1355 | (assoc key (cdr alist))))))) 1356 | 1357 | (defun _nreverse (x prev) 1358 | (let ((next (cdr x))) 1359 | (setcdr x prev) 1360 | (if (null next) 1361 | x 1362 | (_nreverse next x)))) 1363 | (defun nreverse (list) ; (nreverse '(a b c d)) => (d c b a) 1364 | (cond (list (_nreverse list nil)))) 1365 | 1366 | (defun last (list) 1367 | (if (atom (cdr list)) 1368 | list 1369 | (last (cdr list)))) 1370 | 1371 | (defun nconc (&rest lists) 1372 | (if (null (cdr lists)) 1373 | (car lists) 1374 | (if (null (car lists)) 1375 | (apply nconc (cdr lists)) 1376 | (setcdr (last (car lists)) 1377 | (apply nconc (cdr lists))) 1378 | (car lists)))) 1379 | 1380 | (defmacro while (test &rest body) 1381 | (let ((loop (gensym))) 1382 | `(letrec ((,loop (lambda () (cond (,test ,@body (,loop)))))) 1383 | (,loop)))) 1384 | 1385 | (defmacro dolist (spec &rest body) ; (dolist (name list [result]) body...) 1386 | (let ((name (car spec)) 1387 | (list (gensym))) 1388 | `(let (,name 1389 | (,list ,(cadr spec))) 1390 | (while ,list 1391 | (setq ,name (car ,list)) 1392 | ,@body 1393 | (setq ,list (cdr ,list))) 1394 | ,@(if (cddr spec) 1395 | `((setq ,name nil) 1396 | ,(caddr spec)))))) 1397 | 1398 | (defmacro dotimes (spec &rest body) ; (dotimes (name count [result]) body...) 1399 | (let ((name (car spec)) 1400 | (count (gensym))) 1401 | `(let ((,name 0) 1402 | (,count ,(cadr spec))) 1403 | (while (< ,name ,count) 1404 | ,@body 1405 | (setq ,name (+ ,name 1))) 1406 | ,@(if (cddr spec) 1407 | `(,(caddr spec)))))) 1408 | "; 1409 | } 1410 | -------------------------------------------------------------------------------- /lisp.csproj: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | Exe 5 | net6.0 6 | False 7 | False 8 | false 9 | 10 | 11 | 12 | 13 | 14 | 15 | 16 | --------------------------------------------------------------------------------