git.gag.com Git - fw/altos/blob - src/lisp/ao_lisp_builtin.c

   1 /*
   2  * Copyright © 2016 Keith Packard <keithp@keithp.com>
   3  *
   4  * This program is free software; you can redistribute it and/or modify
   5  * it under the terms of the GNU General Public License as published by
   6  * the Free Software Foundation, either version 2 of the License, or
   7  * (at your option) any later version.
   8  *
   9  * This program is distributed in the hope that it will be useful, but
  10  * WITHOUT ANY WARRANTY; without even the implied warranty of
  11  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  12  * General Public License for more details.
  13  */
  14
  15 #include "ao_lisp.h"
  16
  17 static int
  18 builtin_size(void *addr)
  19 {
  20         (void) addr;
  21         return sizeof (struct ao_lisp_builtin);
  22 }
  23
  24 static void
  25 builtin_mark(void *addr)
  26 {
  27         (void) addr;
  28 }
  29
  30 static void
  31 builtin_move(void *addr)
  32 {
  33         (void) addr;
  34 }
  35
  36 const struct ao_lisp_type ao_lisp_builtin_type = {
  37         .size = builtin_size,
  38         .mark = builtin_mark,
  39         .move = builtin_move
  40 };
  41
  42 void
  43 ao_lisp_builtin_print(ao_poly b)
  44 {
  45         (void) b;
  46         printf("[builtin]");
  47 }
  48
  49 static int check_argc(struct ao_lisp_cons *cons, int min, int max)
  50 {
  51         int     argc = 0;
  52
  53         while (cons && argc <= max) {
  54                 argc++;
  55                 cons = ao_lisp_poly_cons(cons->cdr);
  56         }
  57         if (argc < min || argc > max) {
  58                 ao_lisp_exception |= AO_LISP_INVALID;
  59                 return 0;
  60         }
  61         return 1;
  62 }
  63
  64 static int check_argt(struct ao_lisp_cons *cons, int argc, int type, int nil_ok)
  65 {
  66         ao_poly car;
  67
  68         /* find the desired arg */
  69         while (argc--)
  70                 cons = ao_lisp_poly_cons(cons->cdr);
  71         car = cons->car;
  72         if ((!car && !nil_ok) ||
  73             ao_lisp_poly_type(car) != type)
  74         {
  75                 ao_lisp_exception |= AO_LISP_INVALID;
  76                 return 0;
  77         }
  78         return 1;
  79 }
  80
  81 enum math_op { math_plus, math_minus, math_times, math_divide, math_mod };
  82
  83 ao_poly
  84 ao_lisp_car(struct ao_lisp_cons *cons)
  85 {
  86         if (!check_argc(cons, 1, 1))
  87                 return AO_LISP_NIL;
  88         if (!check_argt(cons, 0, AO_LISP_CONS, 0)) {
  89                 ao_lisp_exception |= AO_LISP_INVALID;
  90                 return AO_LISP_NIL;
  91         }
  92         return ao_lisp_poly_cons(cons->car)->car;
  93 }
  94
  95 ao_poly
  96 ao_lisp_cdr(struct ao_lisp_cons *cons)
  97 {
  98         if (!cons) {
  99                 ao_lisp_exception |= AO_LISP_INVALID;
 100                 return AO_LISP_NIL;
 101         }
 102         if (!cons->car) {
 103                 ao_lisp_exception |= AO_LISP_INVALID;
 104                 return AO_LISP_NIL;
 105         }
 106         if (ao_lisp_poly_type(cons->car) != AO_LISP_CONS) {
 107                 ao_lisp_exception |= AO_LISP_INVALID;
 108                 return AO_LISP_NIL;
 109         }
 110         return ao_lisp_poly_cons(cons->car)->cdr;
 111 }
 112
 113 ao_poly
 114 ao_lisp_cons(struct ao_lisp_cons *cons)
 115 {
 116         ao_poly car, cdr;
 117         if (!cons) {
 118                 ao_lisp_exception |= AO_LISP_INVALID;
 119                 return AO_LISP_NIL;
 120         }
 121         car = cons->car;
 122         cdr = cons->cdr;
 123         if (!car || !cdr) {
 124                 ao_lisp_exception |= AO_LISP_INVALID;
 125                 return AO_LISP_NIL;
 126         }
 127         cdr = ao_lisp_poly_cons(cdr)->car;
 128         if (ao_lisp_poly_type(cdr) != AO_LISP_CONS) {
 129                 ao_lisp_exception |= AO_LISP_INVALID;
 130                 return AO_LISP_NIL;
 131         }
 132         return ao_lisp_cons_poly(ao_lisp_cons_cons(car, ao_lisp_poly_cons(cdr)));
 133 }
 134
 135 ao_poly
 136 ao_lisp_quote(struct ao_lisp_cons *cons)
 137 {
 138         if (!cons) {
 139                 ao_lisp_exception |= AO_LISP_INVALID;
 140                 return AO_LISP_NIL;
 141         }
 142         return cons->car;
 143 }
 144
 145 ao_poly
 146 ao_lisp_set(struct ao_lisp_cons *cons)
 147 {
 148         if (!check_argc(cons, 2, 2))
 149                 return AO_LISP_NIL;
 150         if (!check_argt(cons, 0, AO_LISP_ATOM, 0))
 151                 return AO_LISP_NIL;
 152
 153         return ao_lisp_atom_set(cons->car, ao_lisp_poly_cons(cons->cdr)->car);
 154 }
 155
 156 ao_poly
 157 ao_lisp_setq(struct ao_lisp_cons *cons)
 158 {
 159         struct ao_lisp_cons     *expand = 0;
 160         if (!check_argc(cons, 2, 2))
 161                 return AO_LISP_NIL;
 162         expand = ao_lisp_cons_cons(_ao_lisp_atom_set,
 163                                    ao_lisp_cons_cons(ao_lisp_cons_poly(ao_lisp_cons_cons(_ao_lisp_atom_quote,
 164                                                                        ao_lisp_cons_cons(cons->car, NULL))),
 165                                                      ao_lisp_poly_cons(cons->cdr)));
 166         return ao_lisp_cons_poly(expand);
 167 }
 168
 169 ao_poly
 170 ao_lisp_print(struct ao_lisp_cons *cons)
 171 {
 172         ao_poly val = AO_LISP_NIL;
 173         while (cons) {
 174                 val = cons->car;
 175                 ao_lisp_poly_print(val);
 176                 cons = ao_lisp_poly_cons(cons->cdr);
 177                 if (cons)
 178                         printf(" ");
 179         }
 180         return val;
 181 }
 182
 183 ao_poly
 184 ao_lisp_math(struct ao_lisp_cons *cons, enum math_op op)
 185 {
 186         ao_poly ret = AO_LISP_NIL;
 187
 188         while (cons) {
 189                 ao_poly         car = cons->car;
 190                 uint8_t         rt = ao_lisp_poly_type(ret);
 191                 uint8_t         ct = ao_lisp_poly_type(car);
 192
 193                 cons = ao_lisp_poly_cons(cons->cdr);
 194
 195                 if (rt == AO_LISP_NIL)
 196                         ret = car;
 197
 198                 else if (rt == AO_LISP_INT && ct == AO_LISP_INT) {
 199                         int     r = ao_lisp_poly_int(ret);
 200                         int     c = ao_lisp_poly_int(car);
 201
 202                         switch(op) {
 203                         case math_plus:
 204                                 r += c;
 205                                 break;
 206                         case math_minus:
 207                                 r -= c;
 208                                 break;
 209                         case math_times:
 210                                 r *= c;
 211                                 break;
 212                         case math_divide:
 213                                 if (c == 0) {
 214                                         ao_lisp_exception |= AO_LISP_DIVIDE_BY_ZERO;
 215                                         return AO_LISP_NIL;
 216                                 }
 217                                 r /= c;
 218                                 break;
 219                         case math_mod:
 220                                 if (c == 0) {
 221                                         ao_lisp_exception |= AO_LISP_DIVIDE_BY_ZERO;
 222                                         return AO_LISP_NIL;
 223                                 }
 224                                 r %= c;
 225                                 break;
 226                         }
 227                         ret = ao_lisp_int_poly(r);
 228                 }
 229
 230                 else if (rt == AO_LISP_STRING && ct == AO_LISP_STRING && op == math_plus)
 231                         ret = ao_lisp_string_poly(ao_lisp_string_cat(ao_lisp_poly_string(ret),
 232                                                                      ao_lisp_poly_string(car)));
 233                 else {
 234                         ao_lisp_exception |= AO_LISP_INVALID;
 235                         return AO_LISP_NIL;
 236                 }
 237         }
 238         return ret;
 239 }
 240
 241 ao_poly
 242 ao_lisp_plus(struct ao_lisp_cons *cons)
 243 {
 244         return ao_lisp_math(cons, math_plus);
 245 }
 246
 247 ao_poly
 248 ao_lisp_minus(struct ao_lisp_cons *cons)
 249 {
 250         return ao_lisp_math(cons, math_minus);
 251 }
 252
 253 ao_poly
 254 ao_lisp_times(struct ao_lisp_cons *cons)
 255 {
 256         return ao_lisp_math(cons, math_times);
 257 }
 258
 259 ao_poly
 260 ao_lisp_divide(struct ao_lisp_cons *cons)
 261 {
 262         return ao_lisp_math(cons, math_divide);
 263 }
 264
 265 ao_poly
 266 ao_lisp_mod(struct ao_lisp_cons *cons)
 267 {
 268         return ao_lisp_math(cons, math_mod);
 269 }
 270
 271 ao_lisp_func_t ao_lisp_builtins[] = {
 272         [builtin_car] = ao_lisp_car,
 273         [builtin_cdr] = ao_lisp_cdr,
 274         [builtin_cons] = ao_lisp_cons,
 275         [builtin_quote] = ao_lisp_quote,
 276         [builtin_set] = ao_lisp_set,
 277         [builtin_setq] = ao_lisp_setq,
 278         [builtin_print] = ao_lisp_print,
 279         [builtin_plus] = ao_lisp_plus,
 280         [builtin_minus] = ao_lisp_minus,
 281         [builtin_times] = ao_lisp_times,
 282         [builtin_divide] = ao_lisp_divide,
 283         [builtin_mod] = ao_lisp_mod
 284 };
 285