adding lisp-interpreter

lisp-interpreter/stdlib/0_sequences.scm

@@ -0,0 +1,90 @@
+(define-macro lambda (/\_ args
+           (if (pair? args)
+               (if (pair? (cdr args))
+                   (if (pair? (cdr (cdr args)))
+                       `(/\_ ,(car args) ,(cons 'BEGIN (cdr args)))
+                       `(/\_ ,(car args) ,(car (cdr args))))
+                   (syntax-error "lambda missing body expressions: (lambda (args) body)"))
+               (syntax-error "lambda missing argument: (lambda (args) body)"))))
+
+(define-macro set! (lambda (var x)
+                     (begin
+                       (if (not (symbol? var)) (syntax-error "set! not a variable"))
+                       `(_SET! ,var ,x))))
+
+(define-macro define
+              (lambda (var . exprs)
+                (if (symbol? var)
+                    (if (pair? (cdr exprs))
+                        (syntax-error "define: (define var x)")
+                        `(_DEF ,var ,(car exprs)))
+                    (if (pair? var)
+                        `(_DEF ,(car var)
+                               (LAMBDA ,(cdr var)
+                                       ,(if (null? (cdr exprs)) (car exprs) (cons 'BEGIN exprs))))
+                        (syntax-error "define: not a symbol") ))))
+ 
+(define (first x) (car x)) 
+(define (second x) (car (cdr x))) 
+(define (third x) (car (cdr (cdr x)))) 
+
+(define (some? pred l) 
+  (if (null? l) #f 
+      (if (pred (car l)) #t 
+          (some? pred (cdr l))))) 
+
+(define (_map1-helper proc l result) 
+  (if (null? l) 
+      (reverse! result) 
+      (_map1-helper proc 
+                    (cdr l) 
+                    (cons (proc (car l)) result)))) 
+
+(define (map1 proc l) (_map1-helper proc l '())) 
+
+(define (for-each1 proc l) 
+  (if (null? l) '() 
+      (begin (proc (car l)) (for-each1 proc (cdr l ))))) 
+
+(define (reverse! l) (append-reverse! l '()))
+(define (reverse l) (reverse! (list-copy l))) 
+
+(define (last-pair x) 
+ (if (pair? (cdr x)) 
+  (last-pair (cdr x)) x)) 
+
+(define (list-tail x k) 
+ (if (zero? k) x 
+  (list-tail (cdr x) (- k 1)))) 
+
+(define (fold-left op acc lst)
+  (if (null? lst) acc 
+      (fold-left op (op acc (car lst)) (cdr lst))))
+
+(define (_expand-shorthand-body path) 
+  (if (null? path) (cons 'pair '()) 
+      (list (if (char=? (car path) #\A) 
+            (cons 'CAR (_expand-shorthand-body (cdr path))))))) 
+
+(define (_expand-shorthand text) 
+  (cons 'DEFINE  (cons (list (string->symbol (string-append "C" text "R")) 'pair) 
+        (_expand-shorthand-body (string->list text))))) 
+
+(define-macro _shorthand-accessors (lambda args (cons 'BEGIN (map1 _expand-shorthand args)))) 
+
+(define (vector . args) (list->vector args))
+
+(define (vector-copy v) (subvector v 0 (vector-length v)))
+(define (vector-head v end) (subvector v 0 end)) 
+(define (vector-tail v start) (subvector v start (vector-length v))) 
+ 
+(define (string . chars) (list->string chars)) 
+
+(define (string>=? a b) (not (string<? a b))) 
+(define (string>? a b) (string<? b a)) 
+(define (string<=? a b) (not (string<? b a))) 
+
+(define (string-copy s) (substring s 0 (string-length v)))
+(define (string-head s end) (subvector s 0 end)) 
+(define (string-tail s start) (subvector s start (string-length v))) 
+ 

lisp-interpreter/stdlib/1_forms.scm

@@ -0,0 +1,78 @@
+(define (_make-lambda args body) 
+  (list 'LAMBDA args (if (null? (cdr body)) (car body) (cons 'BEGIN body)))) 
+ 
+
+; (LET <name> ((<var0> <expr0>) ... (<varN> <expr1>)) <body0> ... <bodyN>)
+;  => ((LAMBDA (<var0> ... <varN>) (BEGIN <body0> ... <bodyN>)) <expr0> ... <expr1>)            
+;  => named 
+;    ((lambda ()
+;        (define <name> (LAMBDA (<var0> ... <varN>) (BEGIN <body0> ... <bodyN>)))
+;        (<name> <expr0> ... <exprN>)))
+
+(define (_check-binding-list bindings) 
+  (for-each1 (lambda (entry) 
+               (if (not (pair? entry)) (syntax-error "bad let binding" entry)) 
+               (if (not (symbol? (first entry))) (syntax-error "let entry missing symbol" entry))) bindings)) 
+ 
+(define (_let->combination var bindings body) 
+  (_check-binding-list bindings) 
+  (define body-func (_make-lambda (map1 (lambda (entry) (first entry)) bindings) body)) 
+  (define initial-args (map1 (lambda (entry) (second entry)) bindings)) 
+  (if (null? var) 
+      (cons body-func initial-args) 
+      (list (_make-lambda '() (list (list 'DEFINE var body-func) (cons var initial-args)))))) 
+
+(define-macro let (lambda args  
+                    (if (pair? (first args)) 
+                        (_let->combination '() (car args) (cdr args)) 
+                        (_let->combination (first args) (second args) (cdr (cdr args)))))) 
+
+(define (_let*-helper bindings body) 
+  (if (null? bindings) (if (null? (cdr body)) (car body) (cons 'BEGIN body)) 
+      (list 'LET (list (car bindings)) (_let*-helper (cdr bindings) body)))) 
+
+(define-macro let* (lambda (bindings . body) 
+                     (_check-binding-list bindings) 
+                     (_let*-helper bindings body))) 
+
+(define-macro letrec (lambda (bindings . body) 
+                       (_check-binding-list bindings) 
+                       (cons (_make-lambda (map1 (lambda (entry) (first entry)) bindings) 
+                                           (append (map1 (lambda (entry) (list 'SET! (first entry) (second entry))) 
+                                                         bindings) body)) 
+                             (map1 (lambda (entry) '()) bindings)))) 
+
+
+; (COND (<pred0> <expr0>)
+;       (<pred1> <expr1>)
+;        ...
+;        (else <expr-1>)) 
+; =>
+; (IF <pred0> <expr0>
+;      (if <pred1> <expr1>
+;          ....
+;      (if <predN> <exprN> <expr-1>)) ... )
+
+
+(define (_cond-check-clauses clauses) 
+  (for-each1 (lambda (clause) 
+               (if (not (pair? clause)) (syntax-error "cond: invalid clause")) 
+               (if (null? (cdr clause)) (syntax-error "cond: clause missing expression"))) 
+             clauses)) 
+
+(define (_cond-helper clauses) 
+  (if (null? clauses) '() 
+      (if (eq? (car (car clauses)) 'ELSE) 
+          (cons 'BEGIN (cdr (car clauses))) 
+          (list 'IF 
+                (car (car clauses)) 
+                (cons 'BEGIN (cdr (car clauses))) 
+                (_cond-helper (cdr clauses)))))) 
+
+(define-macro cond (lambda clauses 
+                     (begin 
+                       (_cond-check-clauses clauses) 
+                       (_cond-helper clauses)))) 
+
+
+

lisp-interpreter/stdlib/2_forms.scm

@@ -0,0 +1,75 @@
+(_shorthand-accessors "AA" "DD" "AD" "DA" "AAA" "AAD" "ADA" "DAA" "ADD" "DAD" "DDA" "DDD") 
+
+(define (_and-helper preds) 
+  (cond ((null? preds) #t) 
+        ((null? (cdr preds)) (car preds)) 
+        (else 
+          `(IF ,(car preds) ,(_and-helper (cdr preds)) #f)))) 
+(define-macro and (lambda preds (_and-helper preds))) 
+
+(define (_or-helper preds var) 
+  (cond ((null? preds) #f) 
+        ((null? (cdr preds)) (car preds)) 
+        (else 
+          `(BEGIN (SET! ,var ,(car preds)) 
+                  (IF ,var ,var ,(_or-helper (cdr preds) var)))))) 
+
+(define-macro or (lambda preds 
+                   (let ((var (gensym))) 
+                     `(LET ((,var '())) ,(_or-helper preds var))))) 
+
+(define-macro case (lambda (key . clauses) 
+                     (let ((expr (gensym))) 
+                       `(LET ((,expr ,key)) 
+                          ,(cons 'COND (map1 (lambda (entry) 
+                                               (cons (if (pair? (car entry)) 
+                                                         `(MEMV ,expr (quote ,(car entry))) 
+                                                         (car entry)) 
+                                                     (cdr entry))) clauses)))))) 
+
+(define-macro push 
+              (lambda (v l) 
+                `(begin (set! ,l (cons ,v ,l)) ,l))) 
+
+; (DO ((<var0> <init0> <step0>) ...)  (<test> <result>) <body>)
+(define-macro do 
+              (lambda (vars loop-check . loops) 
+                (let ( (names '()) (inits '()) (steps '()) (f (gensym)) ) 
+                  (for-each1 (lambda (var) 
+                               (push (car var) names) 
+                               (set! var (cdr var)) 
+                               (push (car var) inits) 
+                               (set! var (cdr var)) 
+                               (push (car var) steps)) vars) 
+                  `((LAMBDA () 
+                      (DEFINE ,f (LAMBDA ,names 
+                                   (IF ,(car loop-check) 
+                                       ,(if (pair? (cdr loop-check)) (car (cdr loop-check)) '()) 
+                                       ,(cons 'BEGIN (append loops (list (cons f steps)))) ))) 
+                      ,(cons f inits) 
+                      )) ))) 
+
+(define-macro dotimes 
+              (lambda (form body) 
+                (apply (lambda (i n . result) 
+                         `(DO ((,i 0 (+ ,i 1))) 
+                            ((>= ,i ,n) ,(if (null? result) result (car result)) ) 
+                            ,body) 
+                         ) form))) 
+
+(define-macro swap!
+              (lambda (x y)
+                (let ((temp (gensym)))
+                  `(LET ((,temp ,x))
+                        (SET! ,temp ,x)
+                        (SET! ,x ,y)
+                        (SET! ,y ,temp)))))
+
+(define-macro inc! ; CL incf
+              (lambda (x)
+                `(SET! ,x (+ ,x 1))))
+
+(define-macro dec! ; CL decf
+              (lambda (x)
+                `(SET! ,x (- ,x 1))))
+

lisp-interpreter/stdlib/3_math.scm

@@ -0,0 +1,35 @@
+(define (number? x) (real? x)) 
+(define (odd? x) (not (even? x))) 
+(define (inexact? x) (not (exact? x))) 
+(define (zero? x) (= x 0)) 
+(define (positive? x) (>= x 0)) 
+(define (negative? x) (< x 0)) 
+
+(define (>= a b) (not (< a b))) 
+(define (> a b) (< b a)) 
+(define (<= a b) (not (< b a))) 
+
+(define (max . ls) 
+  (fold-left (lambda (m x) 
+               (if (> x m) 
+                   x 
+                   m)) (car ls) (cdr ls))) 
+
+(define (min . ls) 
+  (fold-left (lambda (m x) 
+               (if (< x m) 
+                   x 
+                   m)) (car ls) (cdr ls))) 
+
+(define (_gcd-helper a b) 
+  (if (= b 0) a (_gcd-helper b (modulo a b)))) 
+
+(define (gcd . args) 
+  (if (null? args) 0 
+      (_gcd-helper (car args) (car (cdr args))))) 
+
+(define (lcm . args) 
+  (if (null? args) 1 
+      (abs (* (/ (car args) (apply gcd args)) 
+              (apply * (cdr args))))))  
+

lisp-interpreter/stdlib/4_sequences.scm

@@ -0,0 +1,133 @@
+(define (map proc . rest) 
+ (define (helper lists result) 
+  (if (some? null? lists) 
+   (reverse! result) 
+   (helper (map1 cdr lists) 
+    (cons (apply proc (map1 car lists)) result)))) 
+ (helper rest '())) 
+
+(define (for-each proc . rest) 
+ (define (helper lists) 
+  (if (some? null? lists) 
+   '() 
+   (begin 
+    (apply proc (map1 car lists)) 
+    (helper (map1 cdr lists))))) 
+ (helper rest)) 
+
+(define (filter pred l) 
+ (define (helper l result) 
+  (cond ((null? l) result) 
+   ((pred (car l)) 
+    (helper (cdr l) (cons (car l) result))) 
+   (else 
+    (helper (cdr l) result)))) 
+ (reverse! (helper l '()))) 
+
+(define (reduce op default lst) 
+  (if (null? lst)
+      default
+      (fold-left op (car lst) (cdr lst)))) 
+
+(define (alist->hash-table alist) 
+  (define h (make-hash-table)) 
+  (for-each1 (lambda (pair) 
+               (hash-table-set! h (car pair) (cdr pair))) alist) 
+  h) 
+
+(define (_assoc key list eq?) 
+ (if (null? list) #f 
+  (let ((pair (car list))) 
+    (if (and (pair? pair) (eq? key (car pair))) 
+        pair 
+        (_assoc key (cdr list) eq?))))) 
+
+(define (assoc key list) (_assoc key list equal?)) 
+(define (assq key list) (_assoc key list eq?)) 
+(define (assv key list) (_assoc key list eqv?)) 
+
+(define (_member x list eq?) 
+ (cond ((null? list) #f) 
+  ((eq? (car list) x) list) 
+  (else (_member x (cdr list) eq?)))) 
+
+(define (member x list) (_member x list equal?)) 
+(define (memq x list) (_member x list eq?)) 
+(define (memv x list) (_member x list eqv?)) 
+ 
+(define (make-initialized-vector l fn) 
+  (let ((v (make-vector l '()))) 
+    (do ((i 0 (+ i 1))) 
+      ((>= i l) v) 
+      (vector-set! v i (fn i))))) 
+
+(define (vector-map fn v) 
+  (make-initialized-vector 
+    (vector-length v) 
+    (lambda (i) (fn (vector-ref v i))))) 
+
+(define (vector-binary-search v key< unwrap-key key) 
+  (define (helper low high mid) 
+    (if (<= (- high low) 1) 
+        (if (key< (unwrap-key (vector-ref v low)) key) #f (vector-ref v low)) 
+        (begin 
+          (set! mid (+ low (quotient (- high low) 2))) 
+          (if (key< key (unwrap-key (vector-ref v mid))) 
+              (helper low mid 0) 
+              (helper mid high 0))))) 
+  (helper 0 (vector-length v) 0)) 
+
+
+(define (_insertsort v lo hi op)
+  (if (= (- hi lo) 0)
+      v
+      (do ((i (+ lo 1) (+ i 1)))
+        ((= i hi) v)
+
+        (define x (vector-ref v i))
+
+        (do ((j i (- j 1)))
+          ((or
+             (= j lo)
+             (not (op x (vector-ref v (- j 1)))))
+             (vector-set! v j x))
+
+          (vector-set! v j (vector-ref v (- j 1))))) ))
+
+(define (_quicksort-partition v lo hi op) 
+  (let ((pivot (vector-ref v (+ lo (/ (- hi lo) 2))))
+        (i (- lo 1))
+        (j (+ hi 1)))
+    (do () 
+      ((>= i j) j) 
+
+      (set! i (+ i 1))
+      (do () 
+        ((not (op (vector-ref v i) pivot)) '()) 
+        (set! i (+ i 1))) 
+
+      (set! j (- j 1))
+      (do () 
+        ((not (op pivot (vector-ref v j))) '()) 
+        (set! j (- j 1))) 
+
+      (if (< i j) (vector-swap! v i j))
+      ))) 
+
+(define (_quicksort-vector v lo hi threshold op) 
+  (if (and (>= lo 0) (>= hi 0) (< lo hi) (> (- hi lo) threshold)) 
+      (let ((p (_quicksort-partition v lo hi op))) 
+        (_quicksort-vector v lo p threshold op) 
+        (_quicksort-vector v (+ p 1) hi threshold op)))) 
+
+(define (sort! v op) 
+  ; quicksort down to a certain level of recursion and
+  ; then use insertion sort to finalize. 
+  (_quicksort-vector v 0 (- (vector-length v) 1) 16 op)
+  (_insertsort v 0 (vector-length v) op)
+  v) 
+
+(define (sort list cmp) (vector->list (sort! (list->vector list) cmp))) 
+
+
+

lisp-interpreter/stdlib/5_streams.scm

@@ -0,0 +1,58 @@
+
+(define-macro delay (lambda (expr)
+                      `(make-promise ,(cons 'LAMBDA
+                                            (cons '()
+                                                  (cons expr '()))))))
+
+(define (force promise)
+  (if (not (promise-forced? promise))
+      (_promise-store! promise ((_promise-procedure promise))))
+  (promise-value promise))
+
+(define-macro cons-stream (lambda (x expr) `(cons ,x (delay ,expr))))
+
+(define (stream-car stream) (car stream))
+(define (stream-cdr stream) (force (cdr stream)))
+
+(define (stream-pair? x)
+  (and (pair? x) (promise? (cdr x))))
+
+(define (stream-null? stream) (null? stream))
+
+(define (stream->list-helper stream result)
+  (if (stream-null? stream)
+      (reverse! result)
+      (stream->list-helper 
+        (force (cdr stream)) 
+        (cons (car stream) result)))) 
+
+(define (stream->list stream) 
+  (stream->list-helper stream '())) 
+
+(define (list->stream list) 
+  (if (null? list) 
+      '() 
+      (cons-stream (car list) (list->stream (cdr list))))) 
+
+(define (stream . args) (list->stream args)) 
+
+(define (stream-head-helper stream k result) 
+  (if (= k 0) 
+      (reverse! result) 
+      (stream-head-helper (force (cdr stream)) (- k 1) (cons (car stream) result)))) 
+
+(define (stream-head stream k) 
+  (stream-head-helper stream k '())) 
+
+(define (stream-tail stream k) 
+  (if (= k 0) 
+      stream 
+      (stream-tail (stream-cdr stream) (- k 1)))) 
+
+(define (stream-filter pred stream) 
+  (cond ((stream-null? stream) the-empty-stream) 
+        ((pred (stream-car stream)) 
+         (cons-stream (stream-car stream) 
+                      (stream-filter pred 
+                                     (stream-cdr stream)))) 
+        (else (stream-filter pred (stream-cdr stream)))))

lisp-interpreter/stdlib/6_other.scm

@@ -0,0 +1,63 @@
+(define (char>=? a b) (not (char<? a b))) 
+(define (char>? a b) (char<? b a)) 
+(define (char<=? a b) (not (char<? b a))) 
+
+(define (char-ci=? a b) (char=? (char-downcase a) (char-downcase b)))
+(define (char-ci<? a b) (char<? (char-downcase a) (char-downcase b)))
+
+(define (char-ci>=? a b) (not (char-ci<? a b))) 
+(define (char-ci>? a b) (char-ci<? b a)) 
+(define (char-ci<=? a b) (not (char-ci<? b a))) 
+
+(define (char-lower-case? c)
+    (and (>= (char->integer c) (char->integer #\a))
+         (<= (char->integer c) (char->integer #\z))))
+
+(define (char-upper-case? c)
+    (and (>= (char->integer c) (char->integer #\A))
+         (<= (char->integer c) (char->integer #\Z))))
+
+(define (procedure? p) (or (compiled-procedure? p) (compound-procedure? p))) 
+
+(define (current-input-port) _current-input-port)
+(define (current-output-port) _current-output-port)
+
+(define (read . args) 
+  (_read (if (null? args)
+           (current-input-port)
+           (car args))))
+
+(define (write obj . args) 
+  (_write obj (if (null? args)
+                (current-output-port)
+                (car args))))
+
+(define (display obj . args) 
+  (_display obj (if (null? args)
+                  (current-output-port)
+                  (car args))))
+
+
+(define (write-char obj . args) 
+  (_write-char obj (if (null? args)
+                     (current-output-port)
+                     (car args))))
+
+(define (flush-output-port . args) 
+  (_flush-output-port (if (null? args)
+                        (current-output-port)
+                        (car args))))
+
+
+(define (newline) (write-char #\newline)) 
+
+(define-macro assert (lambda (body) 
+                       `(if ,body '() 
+                            (begin 
+                              (display (quote ,body)) 
+                              (error " assert failed"))))) 
+
+(define-macro ==>  (lambda (test expected) 
+                `(assert (equal? ,test (quote ,expected))) ))  
+
+

lisp-interpreter/stdlib/concat.sh

@@ -0,0 +1,20 @@
+#!/bin/bash
+
+SRC=*.scm
+
+cat lib.h
+
+echo "// Generated from scheme source."
+echo "#ifdef LISP_IMPLEMENTATION"
+
+for FILE in $SRC
+do
+    echo "static const char* lib_$(basename $FILE .scm)_src_ = "
+    cat $FILE | ./text2c.sh 
+    echo ";"
+    echo ""
+done
+
+cat lib.c
+
+echo "#endif"

lisp-interpreter/stdlib/lib.h

@@ -0,0 +1,31 @@
+/*
+ Created by: Justin Meiners 
+ Repo; https://github.com/justinmeiners/lisp-interpreter
+ License: MIT (See end if file)
+
+ This file contains the scheme standard library.
+ See lisp.h for insructions.
+ */
+
+#ifndef LISP_LIB_H
+#define LISP_LIB_H
+
+#ifdef __cplusplus
+extern "C" {
+#endif
+
+#include <stdio.h>
+#include <stdint.h>
+
+void lisp_lib_load(LispContext ctx);
+
+// convenience for init and load
+LispContext lisp_init_with_lib(void);
+
+#ifdef __cplusplus
+}
+#endif
+
+#endif
+
+

lisp-interpreter/stdlib/text2c.sh

@@ -0,0 +1,9 @@
+#!/bin/bash
+
+read -r -d '' content
+content=${content//'\'/'\\'}
+content=${content//$'\t'/'\t'}
+content=${content//$'\n'/$' \\n\\\n'}
+content=${content//$'\r'/'\r'}
+content=${content//'"'/'\"'}
+echo -n "\"$content\""