artemist/mes
1
0
Fork 0
Code Issues Pull requests Packages Projects Releases Wiki Activity

scm: Add c????r.

Browse source 
* module/mes/base-0.mes (caar, cadr, cdar, cddr, map): Remove.  Update callers.
* module/mes/base.mes (): Remove.
* module/mes/base.mes (cadadr, cddadr, cdddar): New function.
This commit is contained in:
Jan Nieuwenhuizen 2017-04-02 09:35:47 +02:00
parent 2c25f45678
commit 4d933001d5
2 changed files with 36 additions and 14 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

17
module/mes/base-0.mes
View file

@ -35,13 +35,8 @@
(define (primitive-eval e) (core:eval e (current-module)))
(define eval core:eval)
(define (caar x) (car (car x)))
(define (cadr x) (car (cdr x)))
(define (cdar x) (cdr (car x)))
(define (cddr x) (cdr (cdr x)))
(define-macro (defined? x)
(list 'assq x '(cddr (current-module))))
(list 'assq x '(cdr (cdr (current-module)))))
(if (defined? 'current-input-port) #t
(define (current-input-port) 0))
@ -58,7 +53,6 @@
(if (null? (cdr rest)) (car rest)
(cons (car rest) (core:apply cons* (cdr rest) (current-module)))))
(define (apply f h . t) (apply-env f (cons h t) (current-module)))
(define (apply f h . t)
(if (null? t) (core:apply f h (current-module))
(apply f (apply cons* (cons h t)))))
@ -70,9 +64,9 @@
(cons
'(test)
(list (list 'if 'test
(if (pair? (cdar clauses))
(if (eq? (cadar clauses) '=>)
(append2 (cddar clauses) '(test))
(if (pair? (cdr (car clauses)))
(if (eq? (car (cdr (car clauses))) '=>)
(append2 (cdr (cdr (car clauses))) '(test))
(list (cons 'lambda (cons '() (car clauses)))))
(list (cons 'lambda (cons '() (car clauses)))))
(if (pair? (cdr clauses))
@ -81,6 +75,7 @@
(define else #t)
(define (cadr x) (car (cdr x)))
(define-macro (simple-let bindings . rest)
(cons (cons 'lambda (cons (map1 car bindings) rest))
(map1 cadr bindings)))
@ -150,8 +145,8 @@
(list 'set! '*modules* (list cons (list string->symbol (module->file module)) '*modules*))
(list 'load (list string-append '*mes-prefix* (module->file module)))))))
(mes-use-module (srfi srfi-0))
(mes-use-module (mes base))
(mes-use-module (srfi srfi-0))
(mes-use-module (mes quasiquote))
(mes-use-module (mes let))
(mes-use-module (mes scm))

33
module/mes/base.mes
View file

@ -31,15 +31,43 @@
(define (cadr x) (car (cdr x)))
(define (cdar x) (cdr (car x)))
(define (cddr x) (cdr (cdr x)))
(define (caaar x) (car (car (car x))))
(define (caadr x) (car (car (cdr x))))
(define (caddr x) (car (cdr (cdr x))))
(define (cdadr x) (cdr (car (cdr x))))
(define (cadar x) (car (cdr (car x))))
(define (caddr x) (car (cdr (cdr x))))
(define (cdaar x) (cdr (car (car x))))
(define (cdadr x) (cdr (car (cdr x))))
(define (cddar x) (cdr (cdr (car x))))
(define (cdddr x) (cdr (cdr (cdr x))))
(define (caaaar x) (car (car (car (car x)))))
(define (caaadr x) (car (car (car (cdr x)))))
(define (caadar x) (car (car (cdr (car x)))))
(define (caaddr x) (car (car (cdr (cdr x)))))
(define (cadaar x) (car (cdr (car (car x)))))
(define (cadadr x) (car (cdr (car (cdr x)))))
(define (caddar x) (car (cdr (cdr (car x)))))
(define (cadddr x) (car (cdr (cdr (cdr x)))))
(define (cdaaar x) (cdr (car (car (car x)))))
(define (cdaadr x) (cdr (car (car (cdr x)))))
(define (cdadar x) (cdr (car (cdr (car x)))))
(define (cdaddr x) (cdr (car (cdr (cdr x)))))
(define (cddaar x) (cdr (cdr (car (car x)))))
(define (cddadr x) (cdr (cdr (car (cdr x)))))
(define (cdddar x) (cdr (cdr (cdr (car x)))))
(define (cddddr x) (cdr (cdr (cdr (cdr x)))))
(define (identity x) x)
(define call/cc call-with-current-continuation)
@ -91,4 +119,3 @@
(if (null? (cdddr r))
(cons (f (car l) (caar r) (caadr r) (car (caddr r))) (map f (cdr l) (cdar r) (cdadr r) (cdr (caddr r))))
(error 'unsupported (cons* "map 5:" f l r))) )))))