felix/slime
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

better errors and new define syntax

Browse Source
This commit is contained in:
FelixBrendel
2019-03-13 16:01:40 +01:00
parent 181ace1eed
commit edef0b017b
12 changed files with 276 additions and 426 deletions
Download Patch File Download Diff File Expand all files Collapse all files
bin/pre.slime
-223
View File
@@ -1,223 +0,0 @@
(define-syntax when (condition :rest body)
;; (break)
`(if ,condition ,(pair prog body) nil))
;; (list 'if condition (pair 'prog body) nil))
(define-syntax unless (condition :rest body)
`(if ,condition nil ,(pair prog body)))
(define-syntax defun (name arguments :rest body)
;; (type-assert arguments :pair)
;; `(define ,name (lambda ,arguments ,body))
;; TODO(Felix: I think we do not need to wrap the body of the lamba
;; in a prog
;; see if we have a docstring
(if (and (= (type (first body)) :string) (not (= (type (rest body)) :nil)))
(list 'define name (list 'lambda arguments (first body) (pair 'prog (rest body))))
(list 'define name (list 'lambda arguments (pair 'prog body)))))
(define-syntax defspecial (name arguments :rest body)
;; (type-assert arguments :pair)
;; `(define ,name (lambda ,arguments ,body))
;; see if we have a docstring
(if (and (= (type (first body)) :string) (not (= (type (rest body)) :nil)))
(list 'define name (list 'special-lambda arguments (first body) (pair 'prog (rest body))))
(list 'define name (list 'special-lambda arguments (pair 'prog body)))))
;; (cond
;; (p1 v1)
;; (p2 v2))
(define-syntax cond (:rest clauses)
(defun rec (clauses)
(if (= nil clauses)
nil
(list 'if (first (first clauses))
(pair 'prog (rest (first clauses)))
(rec (rest clauses)))))
(rec clauses))
(defun nil? (x)
"Checks if the argument is nil."
(= x nil))
(defun number? (x)
"Checks if the argument is a number."
(= (type x) :number))
(defun symbol? (x)
"Checks if the argument is a symbol."
(= (type x) :symbol))
(defun keyword? (x)
"Checks if the argument is a keyword."
(= (type x) :keyword))
(defun pair? (x)
"Checks if the argument is a pair."
(= (type x) :pair))
(defun string? (x)
"Checks if the argument is a string."
(= (type x) :string))
(defun lambda? (x)
"Checks if the argument is a function."
(= (type x) :dynamic-function))
(defun special-lambda? (x)
"Checks if the argument is a macro."
(= (type x) :dynamic-macro))
(defun built-in-function? (x)
"Checks if the argument is a built-in function."
(= (type x) :built-in-function))
(defun apply (fun seq)
"Applies the funciton to the sequence, as in calls the function
with ithe sequence as arguemens."
(eval (pair fun seq)))
(defun end (seq)
"Returns the last pair in the sqeuence."
(if (or (nil? seq) (not (pair? (rest seq))))
seq
(end (rest seq))))
(defun last (seq)
"Returns the (first) of the last (pair) of the given sequence."
(first (end seq)))
(defun extend (seq elem)
"Extends a list with the given element, by putting it in
the (rest) of the last element of the sequence."
(when (pair? seq)
(define e (end seq))
(mutate e (pair (first e) elem)))
seq)
(defun append (seq elem)
"Appends an element to a sequence, by extendeing the list
with (pair elem nil)."
(extend seq (pair elem nil)))
(defun length (seq)
"Returns the length of the given sequence."
(if (nil? seq)
0
(incr (length (rest seq)))))
(defun increment (val)
"Adds one to the argument."
(+ val 1))
(defun decrement (val)
"Subtracts one from the argument."
(- val 1))
;; (defmacro n-times (@times @action)
;; "Executes @action @times times."
;; (unless (<= (eval @times) 0)
;; (eval @action)
;; (apply n-times (list (list - @times 1) @action))))
;; (defmacro for (@symbol @from @to :rest @for-body)
;; "Designed to resemble a C style for loop. It takes a symbol as
;; well as its starting number and end number and executes the
;; @for-body with the defined symbol for all numbers between @from
;; to @to, where @to is exclusive."
;; (if (< (eval @from) (eval @to))
;; (macro-define @op incr)
;; (if (> (eval @from) (eval @to))
;; (macro-define @op decr)
;; (macro-define @op nil)))
;; (when @op
;; (macro-define (eval @symbol) (eval @from))
;; (eval (pair prog @for-body))
;; (eval (extend (list for @symbol (@op @from) @to) @for-body))))
(defun range (:keys from :defaults-to 0 to)
"Returns a sequence of numbers starting with the number defined
by the key 'from' and ends with the number defined in 'to'."
(when (< from to)
(pair from (range :from (+ 1 from) :to to))))
(defun range-while (:keys from :defaults-to 0 to)
"Returns a sequence of numbers starting with the number defined
by the key 'from' and ends with the number defined in 'to'."
(define result (list (copy from)))
(define head result)
(mutate from (increment from))
(while (< from to)
(prog
(mutate head (pair (first head) (pair (copy from) nil)))
(define head (rest head))
(mutate from (increment from))))
result)
(defun map (fun seq)
"Takes a function and a sequence as arguments and returns a new
sequence which contains the results of using the first sequences
elemens as argument to that function."
(if (nil? seq)
seq
(pair (fun (first seq))
(map fun (rest seq)))))
(defun reduce (fun seq)
"Takes a function and a sequence as arguments and applies the
function to the argument sequence. This only works correctly if
the given function accepts a variable amount of parameters. If
your funciton is limited to two arguments, use `reduce-binary'
instead."
(apply fun seq))
(defun reduce-binary (fun seq)
"Takes a function and a sequence as arguments and applies the
function to the argument sequence. reduce-binary applies the
arguments `pair-wise' which means it works with binary functions
as compared to `reduce'."
(if (nil? (rest seq))
(first seq)
(fun (first seq)
(reduce-binary fun (rest seq)))))
(defun filter (fun seq)
"Takes a function and a sequence as arguments and applies the
function to every value in the sequence. If the result of that
funciton application returns a truthy value, the original value is
added to a list, which in the end is returned."
(when seq
(if (fun (first seq))
(pair (first seq)
(filter fun (rest seq)))
(filter fun (rest seq)))))
(defun zip (l1 l2)
(if (and (nil? l1) (nil? l2))
nil
(pair (list (first l1) (first l2)) (zip (rest l1) (rest l2)))))
(defun printf (:keys sep :defaults-to " " end :defaults-to "\n" :rest args)
"A wrapper for the built-in (print) that accepts a variable number
of arguments and also provides keywords for specifying the printed
separators between the arguments and what should be printed after the
las argument."
(defspecial printf-quoted (:keys @sep @end :rest @args)
(if (nil? @args)
(prog (print (eval @end)) nil)
(prog
(print (first @args))
(unless (nil? (rest @args))
(print (eval @sep)))
(eval (pair printf-quoted
(extend (list :@sep (eval @sep) :@end (eval @end)) (rest @args)))))))
(eval (pair printf-quoted (extend (list :@sep (eval sep) :@end (eval end)) args))))
(defspecial pe (@expr)
(printf @expr "evaluates to" (eval @expr)))
bin/tests/class_macro.slime
-81
View File
@@ -1,81 +0,0 @@
(defun type-wrap (obj type)
(set-type obj type)
obj)
(define-syntax defclass (name members :rest body)
"Macro for creatating classes."
(defun underscore (sym)
(string->symbol (concat-strings "_" (symbol->string sym))))
(define underscored-members (map underscore members))
;; the wrapping let environment
(define let-body (list 'let (zip members underscored-members)))
;; the body
(map (lambda (fun) (append let-body fun)) body)
;; the dispatch function
(append let-body '(special-lambda (message :rest args)
"This is the docs for the handle"
(eval (extend (list message) args))))
;; stuff it all in the constructor function
(eval (list defun (string->symbol (concat-strings "make-" (symbol->string name))) underscored-members
"This is the handle to an object of the class "
let-body)))
;; (v1 print)
;; (v1 length)
;; (v1 get-x)
;; (v1 set-x 10)
(defclass vector3 (x y z)
(defun get-x () x)
(defun get-y () y)
(defun get-z () z)
(defun set-x (new-x) (mutate x new-x))
(defun set-y (new-y) (mutate y new-y))
(defun set-z (new-z) (mutate z new-z))
(defun length ()
(** (+ (* x x) (* y y) (* z z)) 0.5))
(defun scale (fac)
(mutate x (* fac x))
(mutate y (* fac y))
(mutate z (* fac z))
fac)
(defun add (other)
(make-vector3
(+ x (other get-x))
(+ y (other get-y))
(+ z (other get-z))))
(defun subtract (other)
(make-vector3
(- x (other get-x))
(- y (other get-y))
(- z (other get-z))))
(defun scalar-product (other)
(+ (* x (other get-x))
(* y (other get-y))
(* z (other get-z))))
(defun cross-product (other)
(make-vector3
(- (* y (other get-z)) (* z (other get-y)))
(- (* z (other get-x)) (* x (other get-z)))
(- (* x (other get-y)) (* y (other get-x)))))
(defun printout ()
(printf "[vector3] (" x y z ")"))
)
(define v1 (make-vector3 1 2 3))
(define v2 (make-vector3 3 2 1))
(assert (= (v1 scalar-product v2) 10))
bin/tests/lexical_scope.slime
-11
View File
@@ -1,11 +0,0 @@
(defun make-counter ()
(let ((var 0))
(lambda ()
(mutate var (+ 1 var))
var)))
(define counter (make-counter))
(assert (= (counter) 1))
(assert (= (counter) 3))
(assert (= (counter) 3))