picolisp/core.l

   1 (de MAL-= (A B)
   2    (let (A* (MAL-type A)
   3          B* (MAL-type B))
   4       (cond
   5          ((and (= A* 'map) (= B* 'map))
   6           (MAL-map-= (MAL-value A) (MAL-value B)) )
   7          ((and (memq A* '(list vector)) (memq B* '(list vector)))
   8           (MAL-seq-= (MAL-value A) (MAL-value B)) )
   9          ((= A* B*)
  10           (= (MAL-value A) (MAL-value B)) )
  11          (T NIL) ) ) )
  12
  13 (de MAL-map-= (As Bs)
  14    (when (= (length As) (length Bs))
  15       (let (As* (chunk As) Bs* (chunk Bs))
  16          (catch 'result
  17             (while As*
  18                (let (A (pop 'As*) Key (MAL-value (car A)) Val (cdr A)
  19                      B (find '((X) (= Key (MAL-value (car X)))) Bs*) )
  20                   (when (or (not B) (not (MAL-= Val (cdr B))))
  21                      (throw 'result NIL) ) ) )
  22             T ) ) ) )
  23
  24 (de MAL-seq-= (As Bs)
  25    (when (= (length As) (length Bs))
  26       (catch 'result
  27          (while As
  28             (ifn (MAL-= (pop 'As) (pop 'Bs))
  29                (throw 'result NIL) ) )
  30          T ) ) )
  31
  32 (de MAL-seq? (X)
  33    (memq (MAL-type X) '(list vector)) )
  34
  35 (de MAL-f (X)
  36    (MAL-value (if (isa '+Func X) (get X 'fn) X)) )
  37
  38 (de MAL-swap! @
  39    (let (X (next) Fn (next) Args (rest))
  40       (put X 'value (apply (MAL-f Fn) Args (MAL-value X))) ) )
  41
  42 (de MAL-nth (Seq N)
  43    (let (Seq* (MAL-value Seq) N* (MAL-value N))
  44       (if (< N* (length Seq*))
  45          (nth Seq* (inc N*) 1)
  46          (throw 'err (MAL-error (MAL-string "out of bounds"))) ) ) )
  47
  48 (de chunk (List)
  49    (make
  50       (for (L List L (cddr L))
  51          (link (cons (car L) (cadr L))) ) ) )
  52
  53 (de join (List)
  54    (mapcan '((X) (list (car X) (cdr X))) List) )
  55
  56 (de MAL-assoc @
  57    (let (Map (next) Args (rest))
  58       (MAL-map
  59          (append Args
  60             (join
  61                (filter '((X) (not (find '((Y) (MAL-= (car Y) (car X)))
  62                                      (chunk Args) ) ) )
  63                   (chunk (MAL-value Map)) ) ) ) ) ) )
  64
  65 (de MAL-dissoc @
  66    (let (Map (next) Args (rest))
  67       (MAL-map
  68          (make
  69             (for (L (MAL-value Map) L (cddr L))
  70                (unless (find '((X) (MAL-= (car L) X)) Args)
  71                   (link (car L) (cadr L)) ) ) ) ) ) )
  72
  73 (de MAL-seq (X)
  74    (if (or (= (MAL-type X) 'nil) (not (MAL-value X)))
  75       *MAL-nil
  76       (case (MAL-type X)
  77          (list X)
  78          (vector (MAL-list (MAL-value X)))
  79          (string (MAL-list (mapcar MAL-string (chop (MAL-value X))))) ) ) )
  80
  81 (de MAL-conj @
  82    (let (Seq (next) Args (rest))
  83       (if (= (MAL-type Seq) 'vector)
  84          (MAL-vector (append (MAL-value Seq) Args))
  85          (MAL-list (append (reverse Args) (MAL-value Seq))) ) ) )
  86
  87 (de clone (X)
  88    (let X* (new (val X))
  89       (maps '((C) (put X* (cdr C) (car C))) X)
  90       X* ) )
  91
  92 (de pil-to-mal (X)
  93    (cond
  94       ((not X) *MAL-nil)
  95       ((=T X) *MAL-true)
  96       ((num? X) (MAL-number X))
  97       ((str? X) (MAL-string X))
  98       ((sym? X) (MAL-symbol X))
  99       ((lst? X) (MAL-list (mapcar pil-to-mal X)))
 100       (T (MAL-string (sym X))) ) )
 101
 102 (def '*Ns
 103    '((+ . `(MAL-fn '((A B) (MAL-number (+ (MAL-value A) (MAL-value B))))))
 104      (- . `(MAL-fn '((A B) (MAL-number (- (MAL-value A) (MAL-value B))))))
 105      (* . `(MAL-fn '((A B) (MAL-number (* (MAL-value A) (MAL-value B))))))
 106      (/ . `(MAL-fn '((A B) (MAL-number (/ (MAL-value A) (MAL-value B))))))
 107
 108      (< . `(MAL-fn '((A B) (if (< (MAL-value A) (MAL-value B)) *MAL-true *MAL-false))))
 109      (<= . `(MAL-fn '((A B) (if (<= (MAL-value A) (MAL-value B)) *MAL-true *MAL-false))))
 110      (> . `(MAL-fn '((A B) (if (> (MAL-value A) (MAL-value B)) *MAL-true *MAL-false))))
 111      (>= . `(MAL-fn '((A B) (if (>= (MAL-value A) (MAL-value B)) *MAL-true *MAL-false))))
 112
 113      (= . `(MAL-fn '((A B) (if (MAL-= A B) *MAL-true *MAL-false))))
 114
 115      (list . `(MAL-fn '(@ (MAL-list (rest)))))
 116      (list? . `(MAL-fn '((X) (if (= (MAL-type X) 'list) *MAL-true *MAL-false))))
 117      (empty? . `(MAL-fn '((X) (if (and (MAL-seq? X) (not (MAL-value X))) *MAL-true *MAL-false))))
 118      (count . `(MAL-fn '((X) (if (MAL-seq? X) (MAL-number (length (MAL-value X))) (MAL-number 0)))))
 119
 120      (pr-str . `(MAL-fn '(@ (MAL-string (glue " " (mapcar '((X) (pr-str X T)) (rest)))))))
 121      (str . `(MAL-fn '(@ (MAL-string (pack (mapcar pr-str (rest)))))))
 122      (prn . `(MAL-fn '(@ (prinl (glue " " (mapcar '((X) (pr-str X T)) (rest)))) *MAL-nil)))
 123      (println . `(MAL-fn '(@ (prinl (glue " " (mapcar pr-str (rest)))) *MAL-nil)))
 124
 125      (read-string . `(MAL-fn '((X) (read-str (MAL-value X)))))
 126      (slurp . `(MAL-fn '((X) (MAL-string (in (MAL-value X) (till NIL T))))))
 127
 128      (atom . `(MAL-fn '((X) (MAL-atom X))))
 129      (atom? . `(MAL-fn '((X) (if (= (MAL-type X) 'atom) *MAL-true *MAL-false))))
 130      (deref . `(MAL-fn '((X) (MAL-value X))))
 131      (reset! . `(MAL-fn '((X Value) (put X 'value Value))))
 132      (swap! . `(MAL-fn MAL-swap!))
 133
 134      (cons . `(MAL-fn '((X Seq) (MAL-list (cons X (MAL-value Seq))))))
 135      (concat . `(MAL-fn '(@ (MAL-list (apply append (mapcar MAL-value (rest)))))))
 136
 137      (nth . `(MAL-fn MAL-nth))
 138      (first . `(MAL-fn '((X) (if (MAL-seq? X) (or (car (MAL-value X)) *MAL-nil) *MAL-nil))))
 139      (rest . `(MAL-fn '((X) (if (MAL-seq? X) (MAL-list (cdr (MAL-value X))) (MAL-list NIL)))))
 140
 141      (throw . `(MAL-fn '((X) (throw 'err (MAL-error X)))))
 142
 143      (apply . `(MAL-fn '(@ (let (Fn (next) X (rest)) (apply (MAL-f Fn) (append (head -1 X) (MAL-value (last X))))))))
 144      (map . `(MAL-fn '((Fn Seq) (MAL-list (mapcar (MAL-f Fn) (MAL-value Seq))))))
 145
 146      (nil? . `(MAL-fn '((X) (if (= (MAL-type X) 'nil) *MAL-true *MAL-false))))
 147      (true? . `(MAL-fn '((X) (if (= (MAL-type X) 'true) *MAL-true *MAL-false))))
 148      (false? . `(MAL-fn '((X) (if (= (MAL-type X) 'false) *MAL-true *MAL-false))))
 149      (number? . `(MAL-fn '((X) (if (= (MAL-type X) 'number) *MAL-true *MAL-false))))
 150      (symbol? . `(MAL-fn '((X) (if (= (MAL-type X) 'symbol) *MAL-true *MAL-false))))
 151      (keyword? . `(MAL-fn '((X) (if (= (MAL-type X) 'keyword) *MAL-true *MAL-false))))
 152      (string? . `(MAL-fn '((X) (if (= (MAL-type X) 'string) *MAL-true *MAL-false))))
 153      (vector? . `(MAL-fn '((X) (if (= (MAL-type X) 'vector) *MAL-true *MAL-false))))
 154      (map? . `(MAL-fn '((X) (if (= (MAL-type X) 'map) *MAL-true *MAL-false))))
 155      (sequential? . `(MAL-fn '((X) (if (MAL-seq? X) *MAL-true *MAL-false))))
 156      (fn? . `(MAL-fn '((X) (if (or (= (MAL-type X) 'fn) (and (= (MAL-type X) 'func) (not (get X 'is-macro)))) *MAL-true *MAL-false))))
 157      (macro? . `(MAL-fn '((X) (if (and (= (MAL-type X) 'func) (get X 'is-macro)) *MAL-true *MAL-false))))
 158
 159      (symbol . `(MAL-fn '((Name) (MAL-symbol (MAL-value Name)))))
 160      (keyword . `(MAL-fn '((X) (if (= (MAL-type X) 'keyword) X (MAL-keyword (MAL-value X))))))
 161      (vector . `(MAL-fn '(@ (MAL-vector (rest)))))
 162      (hash-map . `(MAL-fn '(@ (MAL-map (rest)))))
 163
 164      (assoc . `(MAL-fn MAL-assoc))
 165      (dissoc . `(MAL-fn MAL-dissoc))
 166      (get . `(MAL-fn '((Map Key) (or (and (<> (MAL-type Map) 'nil) (cdr (find '((X) (MAL-= (car X) Key)) (chunk (MAL-value Map))))) *MAL-nil))))
 167      (contains? . `(MAL-fn '((Map Key) (if (find '((X) (MAL-= (car X) Key)) (chunk (MAL-value Map))) *MAL-true *MAL-false))))
 168      (keys . `(MAL-fn '((Map) (MAL-list (mapcar car (chunk (MAL-value Map)))))))
 169      (vals . `(MAL-fn '((Map) (MAL-list (extract cdr (chunk (MAL-value Map)))))))
 170
 171      (with-meta . `(MAL-fn '((X Meta) (let X* (clone X) (put X* 'meta Meta) X*))))
 172      (meta . `(MAL-fn '((X) (or (MAL-meta X) *MAL-nil))))
 173
 174      (readline . `(MAL-fn '((Prompt) (let Output (readline (MAL-value Prompt)) (if (=0 Output) NIL (MAL-string Output))))))
 175      (time-ms . `(MAL-fn '(() (MAL-number (/ (usec) 1000)))))
 176      (conj . `(MAL-fn MAL-conj))
 177      (seq . `(MAL-fn MAL-seq))
 178
 179      (pil-eval . `(MAL-fn '((Input) (pil-to-mal (run (str (MAL-value Input))))))) ) )