X-Git-Url: https://git.gag.com/?a=blobdiff_plain;f=src%2Flisp%2Fao_lisp_const.lisp;h=37307a6877758938bb1f9258a701940770560c30;hb=2e58b6c380bc6440490c47650fbf11d45b3f2e72;hp=9d8af58862e1af43a7fb1c21fe005999cf56178a;hpb=974717eb9dad105c9897ee24f953d98d57eaec77;p=fw%2Faltos diff --git a/src/lisp/ao_lisp_const.lisp b/src/lisp/ao_lisp_const.lisp index 9d8af588..37307a68 100644 --- a/src/lisp/ao_lisp_const.lisp +++ b/src/lisp/ao_lisp_const.lisp @@ -1,14 +1,21 @@ - ; basic list accessors - - -(setq cadr (lambda (l) (car (cdr l)))) -(setq caddr (lambda (l) (car (cdr (cdr l))))) -(setq list (lexpr (l) l)) - - ; evaluate a list of sexprs - -;(setq progn (lexpr (l) (last l))) - +; +; Copyright © 2016 Keith Packard +; +; This program is free software; you can redistribute it and/or modify +; it under the terms of the GNU General Public License as published by +; the Free Software Foundation, either version 2 of the License, or +; (at your option) any later version. +; +; This program is distributed in the hope that it will be useful, but +; WITHOUT ANY WARRANTY; without even the implied warranty of +; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +; General Public License for more details. +; +; Lisp code placed in ROM + + ; return a list containing all of the arguments + +(set (quote list) (lexpr (l) l)) ; ; Define a variable without returning the value @@ -16,24 +23,74 @@ ; having lots of output generated ; -(setq def (macro (def-param) - (list - 'progn - (list - 'set - (list - 'quote - (car def-param)) - (cadr def-param) - ) +(set (quote define) (macro (name val rest) + (list + 'progn + (list + 'set + (list 'quote name) + val) + (list 'quote name) + ) + ) + ) + + ; + ; A slightly more convenient form + ; for defining lambdas. + ; + ; (defun () s-exprs) + ; + +(define defun (macro (name args exprs) (list - 'quote - (car def-param) + define + name + (cons 'lambda (cons args exprs)) ) ) - ) ) + ; basic list accessors + + +(defun cadr (l) (car (cdr l))) + +(defun caddr (l) (car (cdr (cdr l)))) + +(defun nth (list n) + (cond ((= n 0) (car list)) + ((nth (cdr list) (1- n))) + ) + ) + + ; simple math operators + +(defun 1+ (x) (+ x 1)) +(defun 1- (x) (- x 1)) + +(define if (macro (test args) + (cond ((null? (cdr args)) + (list + cond + (list test (car args))) + ) + (else + (list + cond + (list test (car args)) + (list 'else (cadr args)) + ) + ) + ) + ) + ) + +(if (> 3 2) 'yes) +(if (> 3 2) 'yes 'no) +(if (> 2 3) 'no 'yes) +(if (> 2 3) 'no) + ; define a set of local ; variables and then evaluate ; a list of sexprs @@ -50,74 +107,63 @@ ; ; e.g. ; - ; (let ((x 1) (y)) (setq y (+ x 1)) y) + ; (let ((x 1) (y)) (set! y (+ x 1)) y) -(def let (macro (let-param) - ((lambda (vars exprs make-names make-exprs make-nils) - (progn +(define let (macro (vars exprs) + ((lambda (make-names make-exprs make-nils) ; ; make the list of names in the let ; - (setq make-names (lambda (vars) - (cond (vars - (cons (car (car vars)) - (make-names (cdr vars)))) - ) - ) - ) - ; + (set! make-names (lambda (vars) + (cond ((not (null? vars)) + (cons (car (car vars)) + (make-names (cdr vars)))) + ) + ) + ) + ; the set of expressions is ; the list of set expressions ; pre-pended to the ; expressions to evaluate - ; - (setq make-exprs (lambda (vars exprs) - (progn - (cond (vars (cons - (list set - (list quote - (car (car vars)) - ) - (cadr (car vars)) - ) - (make-exprs (cdr vars) exprs) - ) - ) - (exprs) - ) - ) - ) - ) - (setq exprs (make-exprs vars exprs)) - ; - ; the parameters to the lambda is a list - ; of nils of the right length - ; - (setq make-nils (lambda (vars) - (cond (vars (cons nil (make-nils (cdr vars)))) + (set! make-exprs (lambda (vars exprs) + (cond ((not (null? vars)) (cons + (list set + (list quote + (car (car vars)) + ) + (cadr (car vars)) + ) + (make-exprs (cdr vars) exprs) + ) + ) + (exprs) ) ) - ) - ; + ) + + ; the parameters to the lambda is a list + ; of nils of the right length + + (set! make-nils (lambda (vars) + (cond ((not (null? vars)) (cons () (make-nils (cdr vars)))) + ) + ) + ) + ; prepend the set operations + ; to the expressions + + (set! exprs (make-exprs vars exprs)) + ; build the lambda. - ; - (cons - (list - 'lambda - (make-names vars) - (cond ((cdr exprs) (cons 'progn exprs)) - ((car exprs)) - ) - ) - (make-nils vars) - ) - ) + + (cons (cons 'lambda (cons (make-names vars) exprs)) + (make-nils vars) + ) ) - (car let-param) - (cdr let-param) () () () @@ -125,38 +171,52 @@ ) ) - ; - ; A slightly more convenient form - ; for defining lambdas. - ; - ; (defun () s-exprs) - ; +(let ((x 1)) x) -(def defun (macro (defun-param) - (let ((name (car defun-param)) - (args (cadr defun-param)) - (exprs (cdr (cdr defun-param)))) - (list - def - name - (list - 'lambda - args - (cond ((cdr exprs) - (cons progn exprs)) - ((car exprs)) - ) - ) - ) - ) - ) + ; boolean operators + +(define or (lexpr (l) + (let ((ret #f)) + (while (not (null? l)) + (cond ((car l) (set! ret #t) (set! l ())) + ((set! l (cdr l))))) + ret + ) + ) ) - ; simple math operators - ; - ; Do these last to run defun - ; at least once so the let macro - ; is resolved + ; execute to resolve macros -(defun 1+ (x) (+ x 1)) -(defun 1- (x) (- x 1)) +(or #f #t) + +(define and (lexpr (l) + (let ((ret #t)) + (while (not (null? l)) + (cond ((car l) + (set! l (cdr l))) + (#t + (set! ret #f) + (set! l ())) + ) + ) + ret + ) + ) + ) + + ; execute to resolve macros + +(and #t #f) + +(defun equal? (a b) + (cond ((eq? a b) #t) + ((and (pair? a) (pair? b)) + (and (equal? (car a) (car b)) + (equal? (cdr a) (cdr b))) + ) + (else #f) + ) + ) + +(equal? '(a b c) '(a b c)) +(equal? '(a b c) '(a b b))