code.kerkeslager.com Git - sandbox/blob - mini/predefineds.mini

   1 (define cond
   2   (operative cases env
   3              (define cond-internal
   4                (wrap (operative (cases-list) _
   5                                 (if (= cases-list nil)
   6                                   nil
   7                                   (if (evaluate (car (car cases-list)) env)
   8                                     (evaluate (car (cdr (car cases-list))) env)
   9                                     (cond-internal (cdr cases-list)))))))
  10              (cond-internal cases)))
  11
  12 (define cons-list-zip
  13   (wrap (operative (left right) _
  14                    (cond ((and (= left nil) (= right nil)) nil)
  15                          ((= left nil) (assert false))
  16                          ((= right nil) (assert false))
  17                          (true (cons (cons (car left) (car right))
  18                                      (cons-list-zip (cdr left) (cdr right))))))))
  19
  20 # Maybe environments should have been association lists
  21 (define merge-association-list-with-cons-dict
  22   (wrap (operative (a-list cons-dict) _
  23                    (if (= a-list nil)
  24                      cons-dict
  25                      (merge-association-list-with-cons-dict
  26                        (cdr a-list)
  27                        (cons-dict-set cons-dict (car (car a-list)) (cdr (car a-list))))))))
  28
  29 (define cons-list-map
  30   (wrap (operative (f xs) _
  31                    (if (= xs nil)
  32                      nil
  33                      (cons (f (car xs)) (cons-list-map f (cdr xs)))))))
  34
  35 (define function
  36   (operative outer-args outer-env
  37              (define arg-binding (car outer-args))
  38              (define function-body (cdr outer-args))
  39
  40              (define initial-function-env (cons-dict-set nil :__parent__ outer-env))
  41
  42              (wrap (operative inner-args inner-env
  43                               (define function-env
  44                                 (cond ((identifier? arg-binding) (cons-dict-set initial-function-env
  45                                                                                 (identifier->symbol arg-binding)
  46                                                                                 inner-args))
  47                                       ((cons-list? arg-binding) (merge-association-list-with-cons-dict (cons-list-zip (cons-list-map identifier->symbol arg-binding) inner-args)
  48                                                                                                        initial-function-env))
  49                                       (true (assert "Must be an identifier or a cons-list" false))))
  50                               (evaluate-expressions function-body function-env)))))
  51
  52 (define and (operative (left right) env
  53                        (if (evaluate left env)
  54                          (evaluate right env)
  55                          false)))
  56
  57 (define or (operative (left right) env
  58                       (if (evaluate left env)
  59                         true
  60                         (evaluate right env))))
  61
  62 (define quote (operative (quoted-expression) _ quoted-expression))
  63
  64 (define nil? (operative (expression) env
  65                         (= (evaluate expression env) nil)))
  66
  67 (define get-current-environment
  68         (wrap (operative () env env)))
  69
  70 (define cons-list
  71         (wrap (operative items _ items)))