mirror of
https://github.com/kanaka/mal.git
synced 2024-08-17 17:50:24 +03:00
fbfe6784d2
- Add a `vec` built-in function in step7 so that `quasiquote` does not require `apply` from step9. - Introduce quasiquoteexpand special in order to help debugging step7. This may also prepare newcomers to understand step8. - Add soft tests. - Do not quote numbers, strings and so on. Should ideally have been in separate commits: - elisp: simplify and fix (keyword :k) - factor: fix copy/paste error in let*/step7, simplify eval-ast. - guile: improve list/vector types - haskell: revert evaluation during quasiquote - logo, make: cosmetic issues
181 lines
7.6 KiB
Plaintext
181 lines
7.6 KiB
Plaintext
(de MAL-= (A B)
|
|
(let (A* (MAL-type A)
|
|
B* (MAL-type B))
|
|
(cond
|
|
((and (= A* 'map) (= B* 'map))
|
|
(MAL-map-= (MAL-value A) (MAL-value B)) )
|
|
((and (memq A* '(list vector)) (memq B* '(list vector)))
|
|
(MAL-seq-= (MAL-value A) (MAL-value B)) )
|
|
((= A* B*)
|
|
(= (MAL-value A) (MAL-value B)) )
|
|
(T NIL) ) ) )
|
|
|
|
(de MAL-map-= (As Bs)
|
|
(when (= (length As) (length Bs))
|
|
(let (As* (chunk As) Bs* (chunk Bs))
|
|
(catch 'result
|
|
(while As*
|
|
(let (A (pop 'As*) Key (MAL-value (car A)) Val (cdr A)
|
|
B (find '((X) (= Key (MAL-value (car X)))) Bs*) )
|
|
(when (or (not B) (not (MAL-= Val (cdr B))))
|
|
(throw 'result NIL) ) ) )
|
|
T ) ) ) )
|
|
|
|
(de MAL-seq-= (As Bs)
|
|
(when (= (length As) (length Bs))
|
|
(catch 'result
|
|
(while As
|
|
(ifn (MAL-= (pop 'As) (pop 'Bs))
|
|
(throw 'result NIL) ) )
|
|
T ) ) )
|
|
|
|
(de MAL-seq? (X)
|
|
(memq (MAL-type X) '(list vector)) )
|
|
|
|
(de MAL-f (X)
|
|
(MAL-value (if (isa '+Func X) (get X 'fn) X)) )
|
|
|
|
(de MAL-swap! @
|
|
(let (X (next) Fn (next) Args (rest))
|
|
(put X 'value (apply (MAL-f Fn) Args (MAL-value X))) ) )
|
|
|
|
(de MAL-nth (Seq N)
|
|
(let (Seq* (MAL-value Seq) N* (MAL-value N))
|
|
(if (< N* (length Seq*))
|
|
(nth Seq* (inc N*) 1)
|
|
(throw 'err (MAL-error (MAL-string "out of bounds"))) ) ) )
|
|
|
|
(de chunk (List)
|
|
(make
|
|
(for (L List L (cddr L))
|
|
(link (cons (car L) (cadr L))) ) ) )
|
|
|
|
(de join (List)
|
|
(mapcan '((X) (list (car X) (cdr X))) List) )
|
|
|
|
(de MAL-assoc @
|
|
(let (Map (next) Args (rest))
|
|
(MAL-map
|
|
(append Args
|
|
(join
|
|
(filter '((X) (not (find '((Y) (MAL-= (car Y) (car X)))
|
|
(chunk Args) ) ) )
|
|
(chunk (MAL-value Map)) ) ) ) ) ) )
|
|
|
|
(de MAL-dissoc @
|
|
(let (Map (next) Args (rest))
|
|
(MAL-map
|
|
(make
|
|
(for (L (MAL-value Map) L (cddr L))
|
|
(unless (find '((X) (MAL-= (car L) X)) Args)
|
|
(link (car L) (cadr L)) ) ) ) ) ) )
|
|
|
|
(de MAL-seq (X)
|
|
(if (or (= (MAL-type X) 'nil) (not (MAL-value X)))
|
|
*MAL-nil
|
|
(case (MAL-type X)
|
|
(list X)
|
|
(vector (MAL-list (MAL-value X)))
|
|
(string (MAL-list (mapcar MAL-string (chop (MAL-value X))))) ) ) )
|
|
|
|
(de MAL-conj @
|
|
(let (Seq (next) Args (rest))
|
|
(if (= (MAL-type Seq) 'vector)
|
|
(MAL-vector (append (MAL-value Seq) Args))
|
|
(MAL-list (append (reverse Args) (MAL-value Seq))) ) ) )
|
|
|
|
(de clone (X)
|
|
(let X* (new (val X))
|
|
(maps '((C) (put X* (cdr C) (car C))) X)
|
|
X* ) )
|
|
|
|
(de pil-to-mal (X)
|
|
(cond
|
|
((not X) *MAL-nil)
|
|
((=T X) *MAL-true)
|
|
((num? X) (MAL-number X))
|
|
((str? X) (MAL-string X))
|
|
((sym? X) (MAL-symbol X))
|
|
((lst? X) (MAL-list (mapcar pil-to-mal X)))
|
|
(T (MAL-string (sym X))) ) )
|
|
|
|
(def '*Ns
|
|
'((+ . `(MAL-fn '((A B) (MAL-number (+ (MAL-value A) (MAL-value B))))))
|
|
(- . `(MAL-fn '((A B) (MAL-number (- (MAL-value A) (MAL-value B))))))
|
|
(* . `(MAL-fn '((A B) (MAL-number (* (MAL-value A) (MAL-value B))))))
|
|
(/ . `(MAL-fn '((A B) (MAL-number (/ (MAL-value A) (MAL-value B))))))
|
|
|
|
(< . `(MAL-fn '((A B) (if (< (MAL-value A) (MAL-value B)) *MAL-true *MAL-false))))
|
|
(<= . `(MAL-fn '((A B) (if (<= (MAL-value A) (MAL-value B)) *MAL-true *MAL-false))))
|
|
(> . `(MAL-fn '((A B) (if (> (MAL-value A) (MAL-value B)) *MAL-true *MAL-false))))
|
|
(>= . `(MAL-fn '((A B) (if (>= (MAL-value A) (MAL-value B)) *MAL-true *MAL-false))))
|
|
|
|
(= . `(MAL-fn '((A B) (if (MAL-= A B) *MAL-true *MAL-false))))
|
|
|
|
(list . `(MAL-fn '(@ (MAL-list (rest)))))
|
|
(list? . `(MAL-fn '((X) (if (= (MAL-type X) 'list) *MAL-true *MAL-false))))
|
|
(empty? . `(MAL-fn '((X) (if (and (MAL-seq? X) (not (MAL-value X))) *MAL-true *MAL-false))))
|
|
(count . `(MAL-fn '((X) (if (MAL-seq? X) (MAL-number (length (MAL-value X))) (MAL-number 0)))))
|
|
|
|
(pr-str . `(MAL-fn '(@ (MAL-string (glue " " (mapcar '((X) (pr-str X T)) (rest)))))))
|
|
(str . `(MAL-fn '(@ (MAL-string (pack (mapcar pr-str (rest)))))))
|
|
(prn . `(MAL-fn '(@ (prinl (glue " " (mapcar '((X) (pr-str X T)) (rest)))) *MAL-nil)))
|
|
(println . `(MAL-fn '(@ (prinl (glue " " (mapcar pr-str (rest)))) *MAL-nil)))
|
|
|
|
(read-string . `(MAL-fn '((X) (read-str (MAL-value X)))))
|
|
(slurp . `(MAL-fn '((X) (MAL-string (in (MAL-value X) (till NIL T))))))
|
|
|
|
(atom . `(MAL-fn '((X) (MAL-atom X))))
|
|
(atom? . `(MAL-fn '((X) (if (= (MAL-type X) 'atom) *MAL-true *MAL-false))))
|
|
(deref . `(MAL-fn '((X) (MAL-value X))))
|
|
(reset! . `(MAL-fn '((X Value) (put X 'value Value))))
|
|
(swap! . `(MAL-fn MAL-swap!))
|
|
|
|
(cons . `(MAL-fn '((X Seq) (MAL-list (cons X (MAL-value Seq))))))
|
|
(concat . `(MAL-fn '(@ (MAL-list (apply append (mapcar MAL-value (rest)))))))
|
|
(vec . `(MAL-fn '((Seq) (MAL-vector (MAL-value Seq)))))
|
|
|
|
(nth . `(MAL-fn MAL-nth))
|
|
(first . `(MAL-fn '((X) (if (MAL-seq? X) (or (car (MAL-value X)) *MAL-nil) *MAL-nil))))
|
|
(rest . `(MAL-fn '((X) (if (MAL-seq? X) (MAL-list (cdr (MAL-value X))) (MAL-list NIL)))))
|
|
|
|
(throw . `(MAL-fn '((X) (throw 'err (MAL-error X)))))
|
|
|
|
(apply . `(MAL-fn '(@ (let (Fn (next) X (rest)) (apply (MAL-f Fn) (append (head -1 X) (MAL-value (last X))))))))
|
|
(map . `(MAL-fn '((Fn Seq) (MAL-list (mapcar (MAL-f Fn) (MAL-value Seq))))))
|
|
|
|
(nil? . `(MAL-fn '((X) (if (= (MAL-type X) 'nil) *MAL-true *MAL-false))))
|
|
(true? . `(MAL-fn '((X) (if (= (MAL-type X) 'true) *MAL-true *MAL-false))))
|
|
(false? . `(MAL-fn '((X) (if (= (MAL-type X) 'false) *MAL-true *MAL-false))))
|
|
(number? . `(MAL-fn '((X) (if (= (MAL-type X) 'number) *MAL-true *MAL-false))))
|
|
(symbol? . `(MAL-fn '((X) (if (= (MAL-type X) 'symbol) *MAL-true *MAL-false))))
|
|
(keyword? . `(MAL-fn '((X) (if (= (MAL-type X) 'keyword) *MAL-true *MAL-false))))
|
|
(string? . `(MAL-fn '((X) (if (= (MAL-type X) 'string) *MAL-true *MAL-false))))
|
|
(vector? . `(MAL-fn '((X) (if (= (MAL-type X) 'vector) *MAL-true *MAL-false))))
|
|
(map? . `(MAL-fn '((X) (if (= (MAL-type X) 'map) *MAL-true *MAL-false))))
|
|
(sequential? . `(MAL-fn '((X) (if (MAL-seq? X) *MAL-true *MAL-false))))
|
|
(fn? . `(MAL-fn '((X) (if (or (= (MAL-type X) 'fn) (and (= (MAL-type X) 'func) (not (get X 'is-macro)))) *MAL-true *MAL-false))))
|
|
(macro? . `(MAL-fn '((X) (if (and (= (MAL-type X) 'func) (get X 'is-macro)) *MAL-true *MAL-false))))
|
|
|
|
(symbol . `(MAL-fn '((Name) (MAL-symbol (MAL-value Name)))))
|
|
(keyword . `(MAL-fn '((X) (if (= (MAL-type X) 'keyword) X (MAL-keyword (MAL-value X))))))
|
|
(vector . `(MAL-fn '(@ (MAL-vector (rest)))))
|
|
(hash-map . `(MAL-fn '(@ (MAL-map (rest)))))
|
|
|
|
(assoc . `(MAL-fn MAL-assoc))
|
|
(dissoc . `(MAL-fn MAL-dissoc))
|
|
(get . `(MAL-fn '((Map Key) (or (and (<> (MAL-type Map) 'nil) (cdr (find '((X) (MAL-= (car X) Key)) (chunk (MAL-value Map))))) *MAL-nil))))
|
|
(contains? . `(MAL-fn '((Map Key) (if (find '((X) (MAL-= (car X) Key)) (chunk (MAL-value Map))) *MAL-true *MAL-false))))
|
|
(keys . `(MAL-fn '((Map) (MAL-list (mapcar car (chunk (MAL-value Map)))))))
|
|
(vals . `(MAL-fn '((Map) (MAL-list (extract cdr (chunk (MAL-value Map)))))))
|
|
|
|
(with-meta . `(MAL-fn '((X Meta) (let X* (clone X) (put X* 'meta Meta) X*))))
|
|
(meta . `(MAL-fn '((X) (or (MAL-meta X) *MAL-nil))))
|
|
|
|
(readline . `(MAL-fn '((Prompt) (let Output (readline (MAL-value Prompt)) (if (=0 Output) NIL (MAL-string Output))))))
|
|
(time-ms . `(MAL-fn '(() (MAL-number (/ (usec) 1000)))))
|
|
(conj . `(MAL-fn MAL-conj))
|
|
(seq . `(MAL-fn MAL-seq))
|
|
|
|
(pil-eval . `(MAL-fn '((Input) (pil-to-mal (run (str (MAL-value Input))))))) ) )
|