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

   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 ; Lisp code placed in ROM
  15
  16                                         ; return a list containing all of the arguments
  17
  18 (set (quote list) (lexpr (l) l))
  19
  20                                         ;
  21                                         ; Define a variable without returning the value
  22                                         ; Useful when defining functions to avoid
  23                                         ; having lots of output generated
  24                                         ;
  25
  26 (setq def (macro (name val rest)
  27                  (list
  28                   'progn
  29                   (list
  30                    'set
  31                    (list 'quote name)
  32                    val)
  33                   (list 'quote name)
  34                   )
  35                  )
  36       )
  37
  38                                         ;
  39                                         ; A slightly more convenient form
  40                                         ; for defining lambdas.
  41                                         ;
  42                                         ; (defun <name> (<params>) s-exprs)
  43                                         ;
  44
  45 (def defun (macro (name args exprs)
  46                   (list
  47                    def
  48                    name
  49                    (cons 'lambda (cons args exprs))
  50                    )
  51                   )
  52      )
  53
  54                                         ; basic list accessors
  55
  56
  57 (defun cadr (l) (car (cdr l)))
  58
  59 (defun caddr (l) (car (cdr (cdr l))))
  60
  61 (defun nth (list n)
  62   (cond ((= n 0) (car list))
  63         ((nth (cdr list) (1- n)))
  64         )
  65   )
  66
  67                                         ; simple math operators
  68
  69 (defun 1+ (x) (+ x 1))
  70 (defun 1- (x) (- x 1))
  71
  72                                         ; define a set of local
  73                                         ; variables and then evaluate
  74                                         ; a list of sexprs
  75                                         ;
  76                                         ; (let (var-defines) sexprs)
  77                                         ;
  78                                         ; where var-defines are either
  79                                         ;
  80                                         ; (name value)
  81                                         ;
  82                                         ; or
  83                                         ;
  84                                         ; (name)
  85                                         ;
  86                                         ; e.g.
  87                                         ;
  88                                         ; (let ((x 1) (y)) (setq y (+ x 1)) y)
  89
  90 (def let (macro (vars exprs)
  91                 ((lambda (make-names make-exprs make-nils)
  92
  93                                         ;
  94                                         ; make the list of names in the let
  95                                         ;
  96
  97                    (setq make-names (lambda (vars)
  98                                       (cond (vars
  99                                              (cons (car (car vars))
 100                                                    (make-names (cdr vars))))
 101                                             )
 102                                       )
 103                          )
 104
 105                                         ; the set of expressions is
 106                                         ; the list of set expressions
 107                                         ; pre-pended to the
 108                                         ; expressions to evaluate
 109
 110                    (setq make-exprs (lambda (vars exprs)
 111                                       (cond (vars (cons
 112                                                    (list set
 113                                                          (list quote
 114                                                                (car (car vars))
 115                                                                )
 116                                                          (cadr (car vars))
 117                                                          )
 118                                                    (make-exprs (cdr vars) exprs)
 119                                                    )
 120                                                   )
 121                                             (exprs)
 122                                             )
 123                                       )
 124                          )
 125
 126                                         ; the parameters to the lambda is a list
 127                                         ; of nils of the right length
 128
 129                    (setq make-nils (lambda (vars)
 130                                      (cond (vars (cons nil (make-nils (cdr vars))))
 131                                            )
 132                                      )
 133                          )
 134                                         ; prepend the set operations
 135                                         ; to the expressions
 136
 137                    (setq exprs (make-exprs vars exprs))
 138
 139                                         ; build the lambda.
 140
 141                    (cons (cons 'lambda (cons (make-names vars) exprs))
 142                          (make-nils vars)
 143                          )
 144                    )
 145                  ()
 146                  ()
 147                  ()
 148                  )
 149                 )
 150      )
 151
 152                                         ; boolean operators
 153
 154 (def or (lexpr (l)
 155                (let ((ret nil))
 156                  (while l
 157                    (cond ((setq ret (car l))
 158                           (setq l nil))
 159                          ((setq l (cdr l)))))
 160                  ret
 161                  )
 162                )
 163      )
 164
 165                                         ; execute to resolve macros
 166
 167 (or nil t)
 168
 169 (def and (lexpr (l)
 170                (let ((ret t))
 171                  (while l
 172                    (cond ((setq ret (car l))
 173                           (setq l (cdr l)))
 174                          ((setq ret (setq l nil)))
 175                          )
 176                    )
 177                  ret
 178                  )
 179                )
 180      )
 181
 182                                         ; execute to resolve macros
 183
 184 (and t nil)