core.tsp (13900B)
1 ;;; core.tsp 2 (def (list . lst) "Create list" lst) 3 (def quit "type (quit) or press CTRL-D to exit REPL") 4 5 (def defmacro 6 (Macro (args . body) 7 "Define named macro, with argument list and body 8 First element of arguments is name of macro 9 Also see def" 10 (cond 11 ((pair? args) 12 (list 'def (car args) (list 'Macro (cdr args) . body))) 13 (else 14 (error 'defmacro "expected macro name and argument List, recieved " 15 (typeof args)))))) 16 17 ;;; CXR 18 19 ; TODO def car cdr with get syntax ? 20 (def (caar x) (car (car x))) 21 (def (cadr x) (car (cdr x))) 22 (def (cdar x) (cdr (car x))) 23 (def (cddr x) (cdr (cdr x))) 24 (def (caaar x) (car (car (car x)))) 25 (def (caadr x) (car (car (cdr x)))) 26 (def (cadar x) (car (cdr (car x)))) 27 (def (caddr x) (car (cdr (cdr x)))) 28 (def (cdaar x) (cdr (car (car x)))) 29 (def (cdadr x) (cdr (car (cdr x)))) 30 (def (cddar x) (cdr (cdr (car x)))) 31 (def (cdddr x) (cdr (cdr (cdr x)))) 32 (def (caaaar x) (car (car (car (car x))))) 33 (def (caaadr x) (car (car (car (cdr x))))) 34 (def (caadar x) (car (car (cdr (car x))))) 35 (def (caaddr x) (car (car (cdr (cdr x))))) 36 (def (cadaar x) (car (cdr (car (car x))))) 37 (def (cadadr x) (car (cdr (car (cdr x))))) 38 (def (caddar x) (car (cdr (cdr (car x))))) 39 (def (cadddr x) (car (cdr (cdr (cdr x))))) 40 (def (cdaaar x) (cdr (car (car (car x))))) 41 (def (cdaadr x) (cdr (car (car (cdr x))))) 42 (def (cdadar x) (cdr (car (cdr (car x))))) 43 (def (cdaddr x) (cdr (car (cdr (cdr x))))) 44 (def (cddaar x) (cdr (cdr (car (car x))))) 45 (def (cddadr x) (cdr (cdr (car (cdr x))))) 46 (def (cdddar x) (cdr (cdr (cdr (car x))))) 47 (def (cddddr x) (cdr (cdr (cdr (cdr x))))) 48 49 ;;; Types 50 51 (def (any? x) True) 52 (def (void? x) (= (typeof x) "Void")) 53 (def (nil? x) (= (typeof x) "Nil")) 54 (def empty? nil?) 55 (def (integer? x) (= (typeof x) "Int")) ; TODO shorten type querry funcs ? 56 (def (decimal? x) (= (typeof x) "Dec")) 57 (def (ratio? x) (= (typeof x) "Ratio")) 58 (def (string? x) (= (typeof x) "Str")) 59 (def (symbol? x) (= (typeof x) "Sym")) 60 (def (primitive? x) (= (typeof x) "Prim")) 61 (def (specialform? x) (= (typeof x) "Form")) 62 (def (function? x) (= (typeof x) "Func")) 63 (def (macro? x) (= (typeof x) "Macro")) 64 (def (pair? x) (= (typeof x) "Pair")) 65 (def (atom? x) (not (pair? x))) 66 (def (cons? x) (and (pair? x) (not (pair? (cdr x))))) 67 (def (list? x) (if (pair? x) (list? (cdr x)) (not x))) 68 (def (boolean? x) (or (= x True) (nil? x))) 69 (def (true? x) (= x True)) 70 (def false? nil?) 71 (def (builtin? x) (or (primitive? x) (specialform? x))) 72 (def (procedure? x) (or (builtin? x) (or (function? x) (macro? x)))) 73 (def (rational? x) (or (integer? x) (ratio? x))) 74 (def (number? x) (or (rational? x) (decimal? x))) 75 76 (def (Bool x) (if x True Nil)) 77 ; TODO handle string and sym 78 (def (Pair x) 79 (cond 80 ((rational? x) 81 (cons (numerator x) 82 (denominator x))) 83 ((decimal? x) 84 (cons (integer (truncate x)) 85 (- x (truncate x)))) 86 ((or (void? x) (nil? x) (pair? x)) x) 87 (else (cons x Nil)))) 88 89 (defmacro (assert expr) 90 `(unless ,expr 91 (error 'assert "assertion " ',expr " failed"))) 92 93 ; TODO support any sized list n depending on size of optional val 94 (def (default n val) 95 (cond 96 ((nil? n) val) 97 ((and (pair? n) (nil? (cdr n))) 98 (car n)) 99 (else (error 'default "expected only 1 optional argument")))) 100 101 ;;; Control Flow 102 103 ; TODO if b = pair and car b = else use cdr b 104 (defmacro (if con a b) 105 "Execute a if condition con is true, otherwise run b" 106 (list 'cond (list con a) (list True b))) 107 (def else True) 108 (defmacro (when con . body) 109 "Execute body if condition con is true" 110 (list 'cond (list con (cons 'do body)))) 111 (defmacro (unless con . body) 112 "Execute body unless condition, con, is true" 113 (list 'cond (list (list not con) (cons 'do body)))) 114 115 (defmacro (let vars . body) 116 "Execute body with new local variables in vars 117 vars is a list of name and value pairs" 118 (list (list* 'Func () 119 (append 120 (map 121 @(list* 'def (car it) (cdr it)) 122 vars) 123 body)))) 124 125 (defmacro (recur proc vars . body) 126 "Do recursion within body by calling proc with values for vars 127 Also see let" 128 (list 'let 129 (list* 130 (list proc (list* 'Func (map car vars) body)) 131 vars) 132 (list* proc (map car vars)))) 133 134 (defmacro (switch val . body) 135 "Compare value to first element in each body statement, only running line where they are equal" 136 (list* 'cond (map 137 @`((= ,val ,(car it)) ,(cadr it)) 138 body))) 139 140 ; TODO allow for improper lists 141 ; TODO `(0 ,@1) => (0 . 1) 142 (defmacro (quasiquote expr) 143 "Recursively quote the given expression 144 Automatically quotes each element within the expression, but evaluates the 145 element if it is labeled with the unquote macro. 146 Can be shortened with the ` prefix. 147 Also see quote, unquote, and unquote-splice" 148 (def (check form) ; TODO don't redefine functions every call 149 (unless (and (pair? (cdr form)) (nil? (cddr form))) 150 (error (car form) "invalid form " form))) 151 (def (quasicons a d) 152 (if (pair? d) 153 (if (= (car d) 'quote) 154 (if (and (pair? a) (= (car a) 'quote)) 155 (list 'quote (list* (cadr a) (cadr d))) 156 (if (nil? (cadr d)) 157 (list 'list a) 158 (list list* a d))) 159 (if (member (car d) '(list list*)) 160 (list* (car d) a (cdr d)) 161 (list list* a d))) 162 (list list* a d))) 163 (recur f ((expr expr) (n 0)) 164 (cond 165 ((nil? expr) Nil) 166 ((atom? expr) (list 'quote expr)) 167 ((= (car expr) 'quasiquote) 168 (check expr) 169 (quasicons ''quasiquote (f (cdr x) (+ n 1)))) 170 ((= (car expr) 'unquote) 171 (check expr) 172 (if (= n 0) 173 (cadr expr) 174 (quasicons ''unquote (f (cdr expr) (- n 1))))) 175 ((= (car expr) 'unquote-splice) 176 (check expr) 177 (if (= n 0) 178 (error 'unquote-splice "invalid context for " (cadr expr)) 179 (quasicons ''unquote-splice (f (cdr expr) (- n 1))))) 180 ((and (= n 0) (and (pair? (car expr)) (= (caar expr) 'unquote-splice))) 181 (check (car expr)) 182 (let ((d (f (cdr expr) n))) 183 (if d 184 (list 'append (cadar expr) d) 185 (cadar expr)))) 186 (else (quasicons (f (car expr) n) (f (cdr expr) n)))))) 187 188 (defmacro (unquote expr) 189 "Unquote expression so its evaluated before placed into the quasiquote 190 Can be shortened with the , prefix 191 Errors if called outside quasiquote 192 Also see quote, unquote, and unquote-splice" 193 (error 'unquote "called outside of quasiquote")) 194 (defmacro (unquote-splice expr) 195 "Unquote and splice the expression into the quasiquote 196 If the value evaluated is a list, embedded each element into the quasiquote 197 Can be shortened with the ,@ prefix 198 Errors if called outside a quasiquote of a list 199 Also see quote, unquote, and unquote-splice" 200 (error 'unquote-splice "called outside of quasiquote")) 201 202 ;;; Logic 203 204 (def False ()) 205 (def (not x) 206 (if x Nil True)) 207 ; TODO logic func many arguments 208 ; Use a macro so arguments aren't evaluated all at once 209 (defmacro (and a b) 210 "Return b if a is not nil, else return nil" 211 (list 'if a b Nil)) 212 (defmacro (nand a b) 213 "Not and, only true if both a and b are nil, else true" 214 (list 'not (list 'and a b))) 215 (defmacro (or a b) 216 "Return a if not nil, else return b" 217 (list 'if a a b)) 218 (defmacro (nor a b) 219 "Not or, only nil if both a and b are not nil, else true" 220 (list 'not (list 'or a b))) 221 222 ;;; Lists 223 224 (def (list* . lst) 225 "Create improper list, last element is not Nil" 226 (if (cdr lst) 227 (cons (car lst) (apply list* (cdr lst))) 228 (car lst))) 229 230 (def (do . body) 231 "Evaluate each expression in body, returning last 232 Also see do0" 233 (last body)) 234 (def (do0 . body) 235 "Evaluate each expression in body, returning first 236 Also see do" 237 (car body)) 238 239 (def (length lst) 240 "Number of elements in given list" 241 (recur f ((lst lst) (x 0)) 242 (if lst 243 (f (cdr lst) (+ x 1)) 244 x))) 245 246 (def (last lst) 247 "Last element of list" 248 ; recur loop ((lst lst) (n (if n (car n) 0))) 249 (if (cdr lst) 250 (last (cdr lst)) 251 (car lst))) 252 253 ; TODO make nth generic for list str vec, made up of list-ref vec-ref str-ref 254 (def (nth lst n) 255 "Element number n of list, starting from 0 256 If negative get number from end of list" 257 (cond 258 ((atom? lst) 259 (error 'nth "index of list out of bounds")) 260 ((< n 0) (nth lst (+ (length lst) n))) 261 ((= n 0) (car lst)) 262 (else (nth (cdr lst) (- n 1))))) 263 264 ; TODO diff name head/tail since conflicts w/ unix 265 ; TODO support negative numers like unix tail/head to count from end backwards 266 (def (head lst n) 267 "First n elements of list" 268 (cond 269 ((<= n 0) Nil) 270 ((atom? lst) 271 (error 'name "index of list out of bounds")) 272 (else (cons (car lst) (head (cdr lst) (- n 1)))))) 273 274 (def (tail lst n) 275 "Last n elements of list" 276 (cond 277 ((<= n 0) lst) 278 ((atom? lst) 279 (error 'tail "index of list out of bounds")) 280 (else (tail (cdr lst) (- n 1))))) 281 282 (def (count elem lst) ; TODO swap arg order? 283 (cond ((nil? lst) 0) 284 ((atom? lst) (error 'count "expected proper list")) 285 ((= elem (car lst)) (+ 1 (count elem (cdr lst)))) 286 (else (count elem (cdr lst))))) 287 ; (else (Binary[(elem = car[lst])] + count[elem cdr[lst]])) 288 289 (def (apply proc args) ; TODO many args 290 "Run procedure with given arguments list" 291 (eval (map @(list 'quote it) ; prevent proc and args from being evaluated twice 292 (cons proc args)))) 293 294 ; TODO allow for map proc to access index and lst 295 (def (map proc lst) ; TODO many lsts for proc w/ multi arguments 296 "Evaluate each element of list by giving it to the procedure, returning new list" 297 (if lst 298 (cons (proc (car lst)) 299 (map proc (cdr lst))) 300 Nil)) 301 302 (def (convert from to lst) 303 "Convert every member from of list into to" 304 (map @(if (= from it) to it) lst)) 305 306 ; TODO assoc memp procedure equivalent 307 (def (assoc key table) 308 "Return first list in table where the first element matches the key 309 If not found, return nil" 310 (cond ((nil? table) Nil) 311 ((= key (caar table)) (car table)) 312 (else (assoc key (cdr table))))) 313 314 (def (filter proc lst) 315 "Only keep elements of list where applying proc returns true 316 Also see keep, remove, member, memp" 317 (cond 318 ((not (pair? lst)) Nil) 319 ((proc (car lst)) (cons (car lst) (filter proc (cdr lst)))) 320 (else (filter proc (cdr lst))))) 321 322 ; TODO keep* remove* 323 (def (keep elem lst) 324 "Return list with only elements matching elem 325 Also see filter, remove" 326 (filter @(= elem it) lst)) 327 328 (def (remove elem lst) 329 "Return list without elements matching elem 330 Also see filter, keep" 331 (filter @(/= elem it) lst)) 332 333 (def (memp proc lst) 334 "Return list of elements after first time procedure applied to each is not nil 335 Also see member, filter" 336 (cond ((nil? lst) Nil) 337 ((proc (car lst)) lst) 338 (else (memp proc (cdr lst))))) 339 340 (def (member elem lst) 341 "Return list of elements after first matching elem 342 Also see memp, filter" 343 (memp @(= elem it) lst)) 344 345 (def (everyp? proc lst) 346 "Return boolean if every element in list passes proc" 347 (if (pair? lst) 348 (if (proc (car lst)) 349 (everyp? proc (cdr lst)) 350 False) 351 True)) 352 353 (def (every? elem lst) 354 "Return boolean if every element in list is equal to elem" 355 (everyp? @(= elem it) lst)) 356 357 (def (compose . procs) 358 "Create function made from chaining procedures given" 359 (cond 360 ((nil? procs) (Func x x)) 361 ((nil? (cdr procs)) (car procs)) 362 (else 363 (Func x 364 ((car procs) (apply (apply compose (cdr procs)) x)))))) 365 366 (def (reverse lst) 367 "Reverse order of list" 368 (recur f ((in lst) (out Nil)) 369 (if (pair? in) 370 (f (cdr in) (cons (car in) out)) 371 out))) 372 373 ; TODO accept many lists to append 374 (def (append x y) 375 "Append list y to end of list x" 376 (cond 377 ((pair? x) (cons (car x) (append (cdr x) y))) 378 ((nil? x) y) 379 (else (error 'append "expected proper list")))) 380 381 ; TODO zip to proper pairs (def zip' (zip args (nil list))) 382 (def (zip x y) ; TODO many args to create longer pairs 383 "Create list of pairs made up of elements of both lists" 384 (cond ((and (nil? x) (nil? y)) Nil) 385 ((or (nil? x) (nil? y)) (error 'zip "given lists of unequal length")) 386 ((and (pair? x) (pair? y)) 387 (cons (cons (car x) (car y)) 388 (zip (cdr x) (cdr y)))))) 389 390 ; English list element accessors 391 (def rest cdr) ; TODO first and rest are generics for list, vec, str types 392 (def first car) ; TODO rename func to new name 393 (recur f ((n 1) 394 (lst '(second third forth fifth sixth seventh eighth ninth tenth))) 395 (when lst 396 (eval `(def (,(car lst) x) (nth x ,n))) 397 (f (+ n 1) (cdr lst)))) 398 399 ;;; Stacks 400 401 (def (push stack val) 402 "Add value to front of stack 403 Also see push!, pop, peek" 404 (cons val stack)) 405 406 (defmacro (push! stack val) 407 "Add value to front of stack, modifying stack 408 Also see push, pop!" 409 `(set! ,stack (push ,stack ,val))) 410 411 (def (pop stack) 412 "Get stack without first element 413 Also see pop!, push, peek" 414 (if stack 415 (cdr stack) 416 (error 'pop "Improper stack"))) 417 418 (defmacro (pop! stack) 419 "Get value at front of stack, removing value 420 Also see pop, push!" 421 `(do0 422 (peek ,stack) 423 (set! ,stack (pop ,stack)))) 424 425 (def (peek stack) 426 "Get value at front of stack 427 Also see push, pop" 428 (if (pair? stack) 429 (car stack) 430 (error 'peak "Improper stack"))) 431 432 (def (swap stack) 433 "Get stack where the first 2 values are swapped 434 Also see swap!, push, pop, peek" 435 (let ((x (peek stack)) 436 (y (peek (pop stack)))) 437 (push (push (pop (pop stack)) x) y))) 438 439 ; TODO swap! use gen sym instead of x and y ? 440 (defmacro (swap! stack) 441 "Modify stack, swapping the first 2 values 442 Also see swap, push!, pop!" 443 `(let ((x (pop! ,stack)) 444 (y (pop! ,stack))) 445 (set! ,stack (push (push ,stack x) y))))