Fcalva/chibi-scheme
1
0
Fork 0
mirror of https://github.com/ashinn/chibi-scheme.git synced 2025-05-19 13:49:17 +02:00
Code Issues Projects Releases Packages Wiki Activity Actions

Adding (scheme cxr) library, removing all other references to c[ad]{3,4]r.

Browse source
This commit is contained in:
Alex Shinn 2012-05-20 15:16:11 +09:00
parent 120a887b3d
commit c8f13f8538
23 changed files with 117 additions and 140 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

8
lib/chibi/ast.scm
View file

@ -356,11 +356,11 @@
;;> Returns the first string cursor of @var{pat} in @var{str}, ;;> Returns the first string cursor of @var{pat} in @var{str},
;;> of @scheme{#f} if it's not found. ;;> of @scheme{#f} if it's not found.
;;> @subsubsubsection{@scheme{(atomically @var{expr})}} ;;> @subsubsubsection{@scheme{(atomically expr)}}
;;> Run @var{expr} atomically, disabling yields. Ideally should only ;;> Run @var{expr} atomically, disabling yields. Ideally should only be
;;> be used for brief, deterministic expressions. If used incorrectly ;;> used for brief, deterministic expressions. If used incorrectly (e.g.
;;> (e.g. running an infinite loop) can render the system unusable. ;;> running an infinite loop) can render the system unusable.
;;> Never expose to a sandbox. ;;> Never expose to a sandbox.
(cond-expand (cond-expand

4
lib/chibi/generic.scm
View file

@ -24,8 +24,8 @@
(define-syntax define-method (define-syntax define-method
(er-macro-transformer (er-macro-transformer
(lambda (e r c) (lambda (e r c)
(let ((name (caadr e)) (let ((name (car (cadr e)))
(params (cdadr e)) (params (cdr (cadr e)))
(body (cddr e))) (body (cddr e)))
`(,(r 'generic-add!) ,name `(,(r 'generic-add!) ,name
(,(r 'list) ,@(map cadr params)) (,(r 'list) ,@(map cadr params))

2
lib/chibi/loop/loop.scm
View file

@ -44,7 +44,7 @@
((pair? posns) ((pair? posns)
(lp (cdr ls) (cdr posns) (cons (car posns) args))) (lp (cdr ls) (cdr posns) (cons (car posns) args)))
(else (else
(lp (cdr ls) posns (cons (cadar ls) args)))))))))))) (lp (cdr ls) posns (cons (car (cdar ls)) args))))))))))))
. body)))) . body))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

2
lib/chibi/mime.scm
View file

@ -170,7 +170,7 @@
(define (mime-header-fold kons knil . o) (define (mime-header-fold kons knil . o)
(let ((src (and (pair? o) (car o))) (let ((src (and (pair? o) (car o)))
(limit (and (pair? o) (pair? (cdr o)) (car (cdr o)))) (limit (and (pair? o) (pair? (cdr o)) (car (cdr o))))
(kons-from (if (and (pair? o) (pair? (cdr o)) (pair? (cddr o))) (caddr o) kons))) (kons-from (if (and (pair? o) (pair? (cdr o)) (pair? (cddr o))) (car (cddr o)) kons)))
((if (string? src) mime-header-fold-string mime-header-fold-port) ((if (string? src) mime-header-fold-string mime-header-fold-port)
kons knil (or src (current-input-port)) limit kons-from))) kons knil (or src (current-input-port)) limit kons-from)))

4
lib/chibi/net.scm
View file

@ -56,9 +56,9 @@
(let ((io (open-net-io host service))) (let ((io (open-net-io host service)))
(if (not (pair? io)) (if (not (pair? io))
(error "couldn't find address" host service) (error "couldn't find address" host service)
(let ((res (proc (cadr io) (caddr io)))) (let ((res (proc (cadr io) (car (cddr io)))))
(close-input-port (cadr io)) (close-input-port (cadr io))
(close-output-port (caddr io)) (close-output-port (car (cddr io)))
(close-file-descriptor (car io)) (close-file-descriptor (car io))
res)))) res))))

8
lib/chibi/net/http.scm
View file

@ -164,13 +164,13 @@
((and (pair? (car ls)) ((and (pair? (car ls))
(eq? 'mime (caar ls)) (eq? 'mime (caar ls))
(pair? (cdar ls)) (pair? (cdar ls))
(pair? (cadar ls)) (pair? (car (cdar ls)))
(memq (caadar ls) '(^ @))) (memq (caar (cdar ls)) '(^ @)))
(let* ((disp0 (mime-ref (cdadar ls) "content-disposition" "")) (let* ((disp0 (mime-ref (cdar (cdar ls)) "content-disposition" ""))
(disp (mime-parse-content-type disp0)) (disp (mime-parse-content-type disp0))
(name (mime-ref disp "name"))) (name (mime-ref disp "name")))
(if name (if name
(lp (cdr ls) (cons (cons name (caddar ls)) res)) (lp (cdr ls) (cons (cons name (cadr (cdar ls))) res))
(lp (cdr ls) res)))) (lp (cdr ls) res))))
(else (else
(lp (cdr ls) res)))) (lp (cdr ls) res))))

10
lib/chibi/optimize/rest.scm
View file

@ -22,7 +22,7 @@
(let ((x (find (lambda (r) (let ((x (find (lambda (r)
(and (eq? name (car r)) (eq? lam (cadr r)))) (and (eq? name (car r)) (eq? lam (cadr r))))
cdrs))) cdrs)))
(and x (list p f (+ (caddr x) 1))))) (and x (list p f (+ (car (cddr x)) 1)))))
(($ Cnd (($ Cnd
((? (lambda (op) (eq? op pair?))) ($ Ref name (_ . (? lambda? lam)))) ((? (lambda (op) (eq? op pair?))) ($ Ref name (_ . (? lambda? lam))))
((? (lambda (op) (eq? op cdr))) ($ Ref name (_ . (? lambda? lam)))) ((? (lambda (op) (eq? op cdr))) ($ Ref name (_ . (? lambda? lam))))
@ -30,7 +30,7 @@
(let ((x (find (lambda (r) (let ((x (find (lambda (r)
(and (eq? name (car r)) (eq? lam (cadr r)))) (and (eq? name (car r)) (eq? lam (cadr r))))
cdrs))) cdrs)))
(and x (list p f (+ (caddr x) 1.0))))) (and x (list p f (+ (car (cddr x)) 1.0)))))
(else #f))) (else #f)))
params params
args)) args))
@ -86,13 +86,13 @@
((not r) ((not r)
x) x)
((eq? op car) ((eq? op car)
`(,local-ref ,(+ 1 (inexact->exact (caddr r))))) `(,local-ref ,(+ 1 (inexact->exact (car (cddr r))))))
((eq? op cdr) ((eq? op cdr)
(make-lit '())) (make-lit '()))
((eq? op pair?) ((eq? op pair?)
`(,> (,num-parameters) ,(+ base (inexact->exact (caddr r))))) `(,> (,num-parameters) ,(+ base (inexact->exact (car (cddr r))))))
((eq? op null?) ((eq? op null?)
`(,<= (,num-parameters) ,(+ base (inexact->exact (caddr r))))) `(,<= (,num-parameters) ,(+ base (inexact->exact (car (cddr r))))))
(else (else
x)))) x))))
(($ Set ref value) (($ Set ref value)

8
lib/chibi/quoted-printable.scm
View file

@ -73,7 +73,7 @@
(let ((src (if (pair? o) (car o) (current-input-port))) (let ((src (if (pair? o) (car o) (current-input-port)))
(start-col (if (and (pair? o) (pair? (cdr o))) (cadr o) 0)) (start-col (if (and (pair? o) (pair? (cdr o))) (cadr o) 0))
(max-col (if (and (pair? o) (pair? (cdr o)) (pair? (cddr o))) (max-col (if (and (pair? o) (pair? (cdr o)) (pair? (cddr o)))
(caddr o) (car (cddr o))
*default-max-col*))) *default-max-col*)))
(qp-encode (if (string? src) src (read-string #f src)) (qp-encode (if (string? src) src (read-string #f src))
start-col max-col "=\r\n"))) start-col max-col "=\r\n")))
@ -85,10 +85,10 @@
(let ((src (if (pair? o) (car o) (current-input-port))) (let ((src (if (pair? o) (car o) (current-input-port)))
(start-col (if (and (pair? o) (pair? (cdr o))) (cadr o) 0)) (start-col (if (and (pair? o) (pair? (cdr o))) (cadr o) 0))
(max-col (if (and (pair? o) (pair? (cdr o)) (pair? (cddr o))) (max-col (if (and (pair? o) (pair? (cdr o)) (pair? (cddr o)))
(caddr o) (car (cddr o))
*default-max-col*)) *default-max-col*))
(nl (if (and (pair? o) (pair? (cdr o)) (pair? (cddr o)) (pair? (cdddr o))) (nl (if (and (pair? o) (pair? (cdr o)) (pair? (cddr o)) (pair? (cdr (cddr o))))
(cadddr o) (cadr (cddr o))
"\r\n"))) "\r\n")))
(let* ((prefix (string-append "=?" encoding "?Q?")) (let* ((prefix (string-append "=?" encoding "?Q?"))
(prefix-length (+ 2 (string-length prefix))) (prefix-length (+ 2 (string-length prefix)))

2
lib/chibi/stty.scm
View file

@ -11,7 +11,7 @@
(for-each (for-each
(lambda (c) (lambda (c)
(let ((type (cadr c)) (let ((type (cadr c))
(value (caddr c))) (value (car (cddr c))))
(hash-table-set! stty-lookup (car c) (cdr c)))) (hash-table-set! stty-lookup (car c) (cdr c))))
;; ripped from the stty man page, then trimmed down to what seemed ;; ripped from the stty man page, then trimmed down to what seemed

2
lib/chibi/test.scm
View file

@ -248,7 +248,7 @@
((and (pair? x) (eq? 'call-with-values (car x))) ((and (pair? x) (eq? 'call-with-values (car x)))
(string-append (string-append
"..." "..."
(truncate-source (if (and (pair? (cadr x)) (eq? 'lambda (caadr x))) (truncate-source (if (and (pair? (cadr x)) (eq? 'lambda (car (cadr x))))
(car (reverse (cadr x))) (car (reverse (cadr x)))
(cadr x)) (cadr x))
(- width 3) (- width 3)

2
lib/chibi/type-inference.scm
View file

@ -35,7 +35,7 @@
((and (pair? a) (eq? (car a) 'param-type)) ((and (pair? a) (eq? (car a) 'param-type))
(and (pair? b) (eq? (car b) 'param-type) (and (pair? b) (eq? (car b) 'param-type)
(eq? (cadr a) (cadr b)) (eq? (cadr a) (cadr b))
(eq? (caddr a) (caddr b)))) (eq? (car (cddr a)) (car (cddr b)))))
((and (pair? a) (eq? (car a) 'return-type)) ((and (pair? a) (eq? (car a) 'return-type))
(and (pair? b) (eq? (car b) 'return-type) (and (pair? b) (eq? (car b) 'return-type)
(eq? (cadr a) (cadr b)))) (eq? (cadr a) (cadr b))))

52
lib/init-7.scm
View file

@ -2,36 +2,10 @@
;; Copyright (c) 2009-2011 Alex Shinn. All rights reserved. ;; Copyright (c) 2009-2011 Alex Shinn. All rights reserved.
;; BSD-style license: http://synthcode.com/license.txt ;; BSD-style license: http://synthcode.com/license.txt
;; provide c[ad]{2,4}r
(define (caar x) (car (car x))) (define (caar x) (car (car x)))
(define (cadr x) (car (cdr x))) (define (cadr x) (car (cdr x)))
(define (cdar x) (cdr (car x))) (define (cdar x) (cdr (car x)))
(define (cddr x) (cdr (cdr x))) (define (cddr x) (cdr (cdr x)))
(define (caaar x) (car (car (car x))))
(define (caadr x) (car (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)))))
;; basic utils ;; basic utils
@ -155,7 +129,7 @@
(list (rename 'if) (rename 'tmp) (list (rename 'if) (rename 'tmp)
(if (null? (cdr cl)) (if (null? (cdr cl))
(rename 'tmp) (rename 'tmp)
(list (caddr cl) (rename 'tmp))) (list (car (cddr cl)) (rename 'tmp)))
(cons (rename 'cond) (cddr expr)))) (cons (rename 'cond) (cddr expr))))
(car cl)) (car cl))
(list (rename 'if) (list (rename 'if)
@ -207,8 +181,8 @@
((and (<= d 0) (pair? (car x)) ((and (<= d 0) (pair? (car x))
(compare (rename 'unquote-splicing) (caar x))) (compare (rename 'unquote-splicing) (caar x)))
(if (null? (cdr x)) (if (null? (cdr x))
(cadar x) (cadr (car x))
(list (rename 'append) (cadar x) (qq (cdr x) d)))) (list (rename 'append) (cadr (car x)) (qq (cdr x) d))))
(else (else
(list (rename 'cons) (qq (car x) d) (qq (cdr x) d))))) (list (rename 'cons) (qq (car x) d) (qq (cdr x) d)))))
((vector? x) (list (rename 'list->vector) (qq (vector->list x) d))) ((vector? x) (list (rename 'list->vector) (qq (vector->list x) d)))
@ -238,14 +212,14 @@
`((,(rename 'lambda) ,vars `((,(rename 'lambda) ,vars
(,(rename 'letrec) ((,(cadr expr) (,(rename 'letrec) ((,(cadr expr)
(,(rename 'lambda) ,vars (,(rename 'lambda) ,vars
,@(cdddr expr)))) ,@(cdr (cddr expr)))))
(,(cadr expr) ,@vars))) (,(cadr expr) ,@vars)))
,@vals) ,@vals)
`((,(rename 'lambda) ,vars ,@(cddr expr)) ,@vals))) `((,(rename 'lambda) ,vars ,@(cddr expr)) ,@vals)))
(map car bindings) (map car bindings)
(map cadr bindings)) (map cadr bindings))
(error "bad let syntax" expr))) (error "bad let syntax" expr)))
(if (identifier? (cadr expr)) (caddr expr) (cadr expr)))))) (if (identifier? (cadr expr)) (car (cddr expr)) (cadr expr))))))
(define-syntax let* (define-syntax let*
(er-macro-transformer (er-macro-transformer
@ -260,8 +234,8 @@
(if (pair? x) (if (pair? (cdr x)) (null? (cddr x)) #f) #f)) (if (pair? x) (if (pair? (cdr x)) (null? (cddr x)) #f) #f))
(cadr expr)) (cadr expr))
#f) #f)
`(,(rename 'let) (,(caadr expr)) `(,(rename 'let) (,(caar (cdr expr)))
(,(rename 'let*) ,(cdadr expr) ,@(cddr expr))) (,(rename 'let*) ,(cdar (cdr expr)) ,@(cddr expr)))
(error "bad let* syntax")))))) (error "bad let* syntax"))))))
(define-syntax case (define-syntax case
@ -282,7 +256,7 @@
(body (cdar ls))) (body (cdar ls)))
((and (pair? (car (car ls))) (null? (cdr (car (car ls))))) ((and (pair? (car (car ls))) (null? (cdr (car (car ls)))))
`(,(rename 'if) (,(rename 'eqv?) ,(rename 'tmp) `(,(rename 'if) (,(rename 'eqv?) ,(rename 'tmp)
(,(rename 'quote) ,(caaar ls))) (,(rename 'quote) ,(car (caar ls))))
,(body (cdar ls)) ,(body (cdar ls))
,(clause (cdr ls)))) ,(clause (cdr ls))))
(else (else
@ -298,11 +272,11 @@
(lambda (expr rename compare) (lambda (expr rename compare)
(let* ((body (let* ((body
`(,(rename 'begin) `(,(rename 'begin)
,@(cdddr expr) ,@(cdr (cddr expr))
(,(rename 'lp) (,(rename 'lp)
,@(map (lambda (x) (if (pair? (cddr x)) (caddr x) (car x))) ,@(map (lambda (x) (if (pair? (cddr x)) (car (cddr x)) (car x)))
(cadr expr))))) (cadr expr)))))
(check (caddr expr)) (check (car (cddr expr)))
(wrap (wrap
(if (null? (cdr check)) (if (null? (cdr check))
`(,(rename 'let) ((,(rename 'tmp) ,(car check))) `(,(rename 'let) ((,(rename 'tmp) ,(car check)))
@ -637,8 +611,8 @@
(_vector->list (rename 'vector->list)) (_vector->list (rename 'vector->list))
(_list->vector (rename 'list->vector))) (_list->vector (rename 'list->vector)))
(define ellipsis (rename (if ellipsis-specified? (cadr expr) '...))) (define ellipsis (rename (if ellipsis-specified? (cadr expr) '...)))
(define lits (if ellipsis-specified? (caddr expr) (cadr expr))) (define lits (if ellipsis-specified? (car (cddr expr)) (cadr expr)))
(define forms (if ellipsis-specified? (cdddr expr) (cddr expr))) (define forms (if ellipsis-specified? (cdr (cddr expr)) (cddr expr)))
(define (next-symbol s) (define (next-symbol s)
(set! count (+ count 1)) (set! count (+ count 1))
(rename (string->symbol (string-append s (number->string count))))) (rename (string->symbol (string-append s (number->string count)))))

6
lib/meta.scm
View file

@ -91,14 +91,14 @@
((not (and (pair? x) (list? x))) ((not (and (pair? x) (list? x)))
(error "invalid module syntax" x)) (error "invalid module syntax" x))
((and (memq (car x) '(prefix drop-prefix)) ((and (memq (car x) '(prefix drop-prefix))
(symbol? (caddr x)) (list? (cadr x))) (symbol? (car (cddr x))) (list? (cadr x)))
(let ((mod-name+imports (resolve-import (cadr x)))) (let ((mod-name+imports (resolve-import (cadr x))))
(cons (car mod-name+imports) (cons (car mod-name+imports)
(map (lambda (i) (map (lambda (i)
(cons ((if (eq? (car x) 'drop-prefix) (cons ((if (eq? (car x) 'drop-prefix)
symbol-drop symbol-drop
symbol-append) symbol-append)
(caddr x) (car (cddr x))
(to-id i)) (to-id i))
(from-id i))) (from-id i)))
(cdr mod-name+imports))))) (cdr mod-name+imports)))))
@ -204,7 +204,7 @@
(if (pair? x) (if (pair? x)
(if (and (= 3 (length x)) (if (and (= 3 (length x))
(eq? 'rename (identifier->symbol (car x)))) (eq? 'rename (identifier->symbol (car x))))
(cons (caddr x) (cadr x)) (cons (car (cddr x)) (cadr x))
(error "invalid module export" x)) (error "invalid module export" x))
x)) x))
(set! ,this-module '()) (set! ,this-module '())

4
lib/scheme/base.sld
View file

@ -16,9 +16,7 @@
bytevector-copy-partial bytevector-copy-partial! bytevector-length bytevector-copy-partial bytevector-copy-partial! bytevector-length
bytevector-u8-ref bytevector-u8-set! bytevector? caar cadr bytevector-u8-ref bytevector-u8-set! bytevector? caar cadr
call-with-current-continuation call-with-port call-with-values call-with-current-continuation call-with-port call-with-values
call/cc car case cdr cdar cddr caaar caadr cadar caddr cdaar cdadr cddar call/cc car case cdr cdar cddr ceiling char->integer
cdddr caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr cdaaar
cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr ceiling char->integer
char-ready? char<=? char<? char=? char>=? char>? char? char-ready? char<=? char<? char=? char>=? char>? char?
close-input-port close-output-port close-port complex? cond cond-expand close-input-port close-output-port close-port complex? cond cond-expand
cons current-error-port current-input-port current-output-port define cons current-error-port current-input-port current-output-port define

12
lib/srfi/1/misc.scm
View file

@ -34,14 +34,14 @@
(define (zip . lists) (apply map list lists)) (define (zip . lists) (apply map list lists))
(define (unzip1 ls) (map car ls)) (define (unzip1 ls) (map first ls))
(define (unzip2 ls) (values (map car ls) (map cadr ls))) (define (unzip2 ls) (values (map first ls) (map second ls)))
(define (unzip3 ls) (values (map car ls) (map cadr ls) (map caddr ls))) (define (unzip3 ls) (values (map first ls) (map second ls) (map third ls)))
(define (unzip4 ls) (define (unzip4 ls)
(values (map car ls) (map cadr ls) (map caddr ls) (map cadddr ls))) (values (map first ls) (map second ls) (map third ls) (map fourth ls)))
(define (unzip5 ls) (define (unzip5 ls)
(values (map car ls) (map cadr ls) (map caddr ls) (values (map first ls) (map second ls) (map third ls) (map fourth ls)
(map cadddr ls) (map (lambda (x) (car (cddddr x))) ls))) (map fifth ls)))
(define (count pred ls . lists) (define (count pred ls . lists)
(if (null? lists) (if (null? lists)

4
lib/srfi/1/selectors.scm
View file

@ -4,8 +4,8 @@
(define first car) (define first car)
(define second cadr) (define second cadr)
(define third caddr) (define (third ls) (car (cdr (cdr ls))))
(define fourth cadddr) (define (fourth ls) (car (cdr (cdr (cdr ls)))))
(define (fifth ls) (car (cdr (cdr (cdr (cdr ls)))))) (define (fifth ls) (car (cdr (cdr (cdr (cdr ls))))))
(define (sixth ls) (car (cdr (cdr (cdr (cdr (cdr ls))))))) (define (sixth ls) (car (cdr (cdr (cdr (cdr (cdr ls)))))))
(define (seventh ls) (car (cdr (cdr (cdr (cdr (cdr (cdr ls)))))))) (define (seventh ls) (car (cdr (cdr (cdr (cdr (cdr (cdr ls))))))))

20
lib/srfi/9.scm
View file

@ -2,13 +2,15 @@
(define-syntax define-record-type (define-syntax define-record-type
(er-macro-transformer (er-macro-transformer
(lambda (expr rename compare) (lambda (expr rename compare)
(let* ((name (if (pair? (cadr expr)) (caadr expr) (cadr expr))) (let* ((name+parent (cadr expr))
(parent (and (pair? (cadr expr)) (cadadr expr))) (name (if (pair? name+parent) (car name+parent) name+parent))
(parent (and (pair? name+parent) (cadr name+parent)))
(name-str (symbol->string (identifier->symbol name))) (name-str (symbol->string (identifier->symbol name)))
(make (caaddr expr)) (procs (cddr expr))
(make-fields (cdaddr expr)) (make (caar procs))
(pred (cadddr expr)) (make-fields (cdar procs))
(fields (cddddr expr)) (pred (cadr procs))
(fields (cddr procs))
(_define (rename 'define)) (_define (rename 'define))
(_lambda (rename 'lambda)) (_lambda (rename 'lambda))
(_let (rename 'let)) (_let (rename 'let))
@ -34,10 +36,10 @@
fields) fields)
,@(map (lambda (f) ,@(map (lambda (f)
(and (pair? f) (pair? (cdr f)) (pair? (cddr f)) (and (pair? f) (pair? (cdr f)) (pair? (cddr f))
`(,_define ,(caddr f) `(,_define ,(car (cddr f))
(,(rename 'make-setter) (,(rename 'make-setter)
,(symbol->string ,(symbol->string
(identifier->symbol (caddr f))) (identifier->symbol (car (cddr f))))
,name ,name
(,_type_slot_offset ,name ',(car f)))))) (,_type_slot_offset ,name ',(car f))))))
fields) fields)
@ -60,7 +62,7 @@
(error "unknown record field in constructor" (car ls))) (error "unknown record field in constructor" (car ls)))
((pair? (cddr field)) ((pair? (cddr field))
(lp (cdr ls) (lp (cdr ls)
(cons `(,(caddr field) res ,(car ls)) sets))) (cons `(,(car (cddr field)) res ,(car ls)) sets)))
(else (else
(lp (cdr ls) (lp (cdr ls)
(cons `(,_slot-set! ,name res (,_type_slot_offset ,name ',(car ls)) ,(car ls)) (cons `(,_slot-set! ,name res (,_type_slot_offset ,name ',(car ls)) ,(car ls))

2
lib/srfi/99/records/inspection.scm
View file

@ -29,6 +29,6 @@
(rtd-field-mutable? p x) (rtd-field-mutable? p x)
(error "unknown field" rtd x)))) (error "unknown field" rtd x))))
((eq? x (car ls))) ((eq? x (car ls)))
((and (pair? (car ls)) (eq? x (cadar ls))) ((and (pair? (car ls)) (eq? x (cadr (car ls))))
(not (eq? 'immutable (caar ls)))) (not (eq? 'immutable (caar ls))))
(else (lp (cdr ls)))))) (else (lp (cdr ls))))))

2
lib/srfi/99/records/procedural.scm
View file

@ -26,7 +26,7 @@
(let lp ((i 0) (ls ls)) (let lp ((i 0) (ls ls))
(cond ((null? ls ) #f) (cond ((null? ls ) #f)
((if (pair? (car ls)) ((if (pair? (car ls))
(eq? field (cadar ls)) (eq? field (car (cdar ls)))
(eq? field (car ls))) (eq? field (car ls)))
i) i)
(else (lp (+ i 1) (cdr ls)))))) (else (lp (+ i 1) (cdr ls))))))

16
lib/srfi/99/records/syntactic.scm
View file

@ -3,18 +3,20 @@
(er-macro-transformer (er-macro-transformer
(lambda (expr rename compare) (lambda (expr rename compare)
(let* ((id->string (lambda (x) (symbol->string (identifier->symbol x)))) (let* ((id->string (lambda (x) (symbol->string (identifier->symbol x))))
(name (if (pair? (cadr expr)) (caadr expr) (cadr expr))) (name+parent (cadr expr))
(parent (and (pair? (cadr expr)) (cadadr expr))) (name (if (pair? name+parent) (car name+parent) name+parent))
(parent (and (pair? name+parent) (cadr name+parent)))
(name-str (id->string name)) (name-str (id->string name))
(make (caddr expr)) (procs (cddr expr))
(make (car procs))
(make-name (if (eq? make #t) (make-name (if (eq? make #t)
(string->symbol (string-append "make-" name-str)) (string->symbol (string-append "make-" name-str))
(if (pair? make) (car make) make))) (if (pair? make) (car make) make)))
(pred (cadddr expr)) (pred (cadr procs))
(pred-name (if (eq? pred #t) (pred-name (if (eq? pred #t)
(string->symbol (string-append name-str "?")) (string->symbol (string-append name-str "?"))
pred)) pred))
(fields (cddddr expr)) (fields (cddr procs))
(field-names (map (lambda (x) (if (pair? x) (car x) x)) fields)) (field-names (map (lambda (x) (if (pair? x) (car x) x)) fields))
(make-fields (if (pair? make) (cdr make) (and (not parent) field-names))) (make-fields (if (pair? make) (cdr make) (and (not parent) field-names)))
(_define (rename 'define)) (_define (rename 'define))
@ -51,7 +53,7 @@
fields) fields)
,@(map (lambda (f) ,@(map (lambda (f)
(let ((s (if (and (pair? f) (pair? (cdr f)) (pair? (cddr f))) (let ((s (if (and (pair? f) (pair? (cdr f)) (pair? (cddr f)))
(caddr f) (car (cddr f))
(and (identifier? f) (and (identifier? f)
(string->symbol (string->symbol
(string-append name-str "-" (id->string f) "-set!")))))) (string-append name-str "-" (id->string f) "-set!"))))))
@ -82,7 +84,7 @@
;; (error "unknown record field in constructor" (car ls))) ;; (error "unknown record field in constructor" (car ls)))
((and (pair? field) (pair? (cdr field)) (pair? (cddr field))) ((and (pair? field) (pair? (cdr field)) (pair? (cddr field)))
(lp (cdr ls) (lp (cdr ls)
(cons (list (caddr field) 'res (car ls)) sets))) (cons (list (car (cddr field)) 'res (car ls)) sets)))
(else (else
(lp (cdr ls) (lp (cdr ls)
(cons `(,_slot-set! ,name res (,_type_slot_offset ,name ',(car ls)) ,(car ls)) sets))))))))) (cons `(,_slot-set! ,name res (,_type_slot_offset ,name ',(car ls)) ,(car ls)) sets)))))))))

4
tests/basic/test10-unhygiene.scm
View file

@ -5,9 +5,9 @@
(let ((condition (let ((condition
(make-syntactic-closure environment '() (cadr form))) (make-syntactic-closure environment '() (cadr form)))
(consequent (consequent
(make-syntactic-closure environment '(it) (caddr form))) (make-syntactic-closure environment '(it) (car (cddr form))))
(alternative (alternative
(make-syntactic-closure environment '() (cadddr form)))) (make-syntactic-closure environment '() (cadr (cddr form)))))
`(let ((it ,condition)) `(let ((it ,condition))
(if it (if it
,consequent ,consequent

38
tools/chibi-doc
View file

@ -90,7 +90,7 @@
(define (sxml-body x) (define (sxml-body x)
(cond ((not (and (pair? x) (pair? (cdr x)))) '()) (cond ((not (and (pair? x) (pair? (cdr x)))) '())
((and (pair? (cadr x)) (eq? '^ (caadr x))) (cddr x)) ((and (pair? (cadr x)) (eq? '^ (car (cadr x)))) (cddr x))
(else (cdr x)))) (else (cdr x))))
(define (env-ref env name . o) (define (env-ref env name . o)
@ -165,9 +165,9 @@
(error "section must not be empty" sxml) (error "section must not be empty" sxml)
(let* ((name (and (eq? 'tag: (cadr sxml)) (let* ((name (and (eq? 'tag: (cadr sxml))
(pair? (cddr sxml)) (pair? (cddr sxml))
(sxml-strip (caddr sxml)))) (sxml-strip (car (cddr sxml)))))
(body (map (lambda (x) (expand x env)) (body (map (lambda (x) (expand x env))
(if name (cdddr sxml) (cdr sxml)))) (if name (cdr (cddr sxml)) (cdr sxml))))
(name (or name (sxml-strip (cons tag body))))) (name (or name (sxml-strip (cons tag body)))))
`(div (a (^ (name . ,(section-name tag name)))) (,tag ,@body)))))) `(div (a (^ (name . ,(section-name tag name)))) (,tag ,@body))))))
@ -195,10 +195,10 @@
(define (expand-code sxml env) (define (expand-code sxml env)
(let* ((hl (if (and (pair? (cdr sxml)) (eq? 'language: (cadr sxml))) (let* ((hl (if (and (pair? (cdr sxml)) (eq? 'language: (cadr sxml)))
(highlighter-for (caddr sxml)) (highlighter-for (car (cddr sxml)))
highlight)) highlight))
(body (if (and (pair? (cdr sxml)) (eq? 'language: (cadr sxml))) (body (if (and (pair? (cdr sxml)) (eq? 'language: (cadr sxml)))
(cdddr sxml) (cdr (cddr sxml))
(cdr sxml)))) (cdr sxml))))
`(code ,@(map-sxml (lambda (x) (if (string? x) (hl x) x)) `(code ,@(map-sxml (lambda (x) (if (string? x) (hl x) x))
(normalize-sxml (normalize-sxml
@ -274,7 +274,7 @@
(if (null? x) (if (null? x)
'() '()
(let ((d (caar x))) (let ((d (caar x)))
(let lp ((ls (cdr x)) (parent (cadar x)) (kids '()) (res '())) (let lp ((ls (cdr x)) (parent (car (cdar x))) (kids '()) (res '()))
(define (collect) (define (collect)
(cons `(li ,parent ,(get-contents (reverse kids))) res)) (cons `(li ,parent ,(get-contents (reverse kids))) res))
(cond (cond
@ -283,7 +283,7 @@
((> (caar ls) d) ((> (caar ls) d)
(lp (cdr ls) parent (cons (car ls) kids) res)) (lp (cdr ls) parent (cons (car ls) kids) res))
(else (else
(lp (cdr ls) (cadar ls) '() (collect)))))))) (lp (cdr ls) (car (cdar ls)) '() (collect))))))))
(define (fix-header x) (define (fix-header x)
`(html (head ,@(cond ((assq 'title x) => (lambda (x) (list x))) `(html (head ,@(cond ((assq 'title x) => (lambda (x) (list x)))
@ -351,7 +351,7 @@ div#footer {padding-bottom: 50px}
(skip-whitespace in)))) (skip-whitespace in))))
(define (external-clause? x) (define (external-clause? x)
(not (and (pair? (cdr x)) (pair? (cadr x)) (string? (caadr x))))) (not (and (pair? (cdr x)) (pair? (cadr x)) (string? (car (cadr x))))))
(define (get-signature proc source form) (define (get-signature proc source form)
(match form (match form
@ -388,10 +388,10 @@ div#footer {padding-bottom: 50px}
(cons (if (pair? (cadr ls)) (cadr ls) (list (cadr ls))) res))) (cons (if (pair? (cadr ls)) (cadr ls) (list (cadr ls))) res)))
((pair? (car ls)) ((pair? (car ls))
(lp (cdr ls) (lp (cdr ls)
(append (if (pair? (cdddar ls)) (append (if (pair? (cddr (cdar ls)))
(list (list (car (cdddar ls)) name (caar ls))) (list (list (car (cddr (cdar ls))) name (caar ls)))
'()) '())
(list (list (caddar ls) name)) (list (list (cadr (cdar ls)) name))
res))) res)))
((symbol? (car ls)) ((symbol? (car ls))
(lp (cddr ls) res)) (lp (cddr ls) res))
@ -433,7 +433,7 @@ div#footer {padding-bottom: 50px}
orig-ls) orig-ls)
(else (else
(let ((name (let ((name
(or name (if (eq? 'const: (caar sig)) (caddar sig) (caar sig))))) (or name (if (eq? 'const: (caar sig)) (cadr (cdar sig)) (caar sig)))))
(let lp ((ls orig-ls) (rev-pre '())) (let lp ((ls orig-ls) (rev-pre '()))
(cond (cond
((or (null? ls) ((or (null? ls)
@ -448,8 +448,8 @@ div#footer {padding-bottom: 50px}
tag: ,(write-to-string name) tag: ,(write-to-string name)
(rawcode (rawcode
,@(if (eq? 'const: (caar sig)) ,@(if (eq? 'const: (caar sig))
`((i ,(write-to-string (cadar sig)) ": ") `((i ,(write-to-string (car (cdar sig))) ": ")
,(write-to-string (caddar sig))) ,(write-to-string (cadr (cdar sig))))
(intersperse (map write-to-string sig) '(br))))))) (intersperse (map write-to-string sig) '(br)))))))
,@ls)) ,@ls))
(else (else
@ -459,10 +459,10 @@ div#footer {padding-bottom: 50px}
(call-with-input-file file (call-with-input-file file
(lambda (in) (lambda (in)
(let* ((lang (or (and (pair? o) (car o)) 'scheme)) (let* ((lang (or (and (pair? o) (car o)) 'scheme))
(defs (map (lambda (x) `(,(car x) ,(cadr x) ,(cdaddr x))) (defs (map (lambda (x) `(,(car x) ,(cadr x) ,(cdar (cddr x))))
(filter (filter
(lambda (x) (lambda (x)
(and (pair? (caddr x)) (equal? file (caaddr x)))) (and (pair? (third x)) (equal? file (car (third x)))))
defs)))) defs))))
(let lp ((lines '()) (cur '()) (res '())) (let lp ((lines '()) (cur '()) (res '()))
(define (collect) (define (collect)
@ -503,14 +503,14 @@ div#footer {padding-bottom: 50px}
(line1 (port-line in)) (line1 (port-line in))
(x (read in)) (x (read in))
(line2 (port-line in)) (line2 (port-line in))
(procs (filter (lambda (x) (<= line1 (caddr x) line2)) (procs (filter (lambda (x) (<= line1 (third x) line2))
(filter caddr defs)))) (filter third defs))))
(cond (cond
((and (eq? lang 'ffi) (get-ffi-signatures x)) ((and (eq? lang 'ffi) (get-ffi-signatures x))
=> (lambda (sigs) => (lambda (sigs)
(let ((sigs (filter (let ((sigs (filter
(lambda (x) (lambda (x)
(memq (if (eq? 'const: (car x)) (caddr x) (car x)) exports)) (memq (if (eq? 'const: (car x)) (third x) (car x)) exports))
sigs))) sigs)))
(lp '() '() (append (insert-signature cur #f sigs) res))))) (lp '() '() (append (insert-signature cur #f sigs) res)))))
((and (eq? lang 'scheme) (= 1 (length procs))) ((and (eq? lang 'scheme) (= 1 (length procs)))

45
tools/chibi-ffi
View file

@ -72,7 +72,7 @@
((result) ((result)
(lp (next) free? const? null-ptr? ptr? ref? struct? link? #t array value default? template)) (lp (next) free? const? null-ptr? ptr? ref? struct? link? #t array value default? template))
((array) ((array)
(lp (cadr type) free? const? null-ptr? ref? ptr? struct? link? result? (if (pair? (cddr type)) (caddr type) #t) value default? template)) (lp (cadr type) free? const? null-ptr? ref? ptr? struct? link? result? (if (pair? (cddr type)) (car (cddr type)) #t) value default? template))
((value) ((value)
(lp (cddr type) free? const? null-ptr? ref? ptr? struct? link? result? array (cadr type) default? template)) (lp (cddr type) free? const? null-ptr? ref? ptr? struct? link? result? array (cadr type) default? template))
((default) ((default)
@ -123,7 +123,7 @@
(let lp ((ls (struct-fields (cdr x)))) (let lp ((ls (struct-fields (cdr x))))
(cond (cond
((null? ls) #f) ((null? ls) #f)
((eq? field (caar ls)) (cadar ls)) ((eq? field (caar ls)) (car (cdar ls)))
(else (lp (cdr ls))))))) (else (lp (cdr ls)))))))
(else (else
#f))) #f)))
@ -190,18 +190,18 @@
(<= 1 (length (cadr func)) 3) (<= 1 (length (cadr func)) 3)
(every (lambda (x) (or (identifier? x) (not x) (string? x))) (every (lambda (x) (or (identifier? x) (not x) (string? x)))
(cadr func)))) (cadr func))))
(list? (caddr func)))) (list? (car (cddr func)))))
(error "bad function definition" func)) (error "bad function definition" func))
(let* ((method? (and (pair? o) (car o))) (let* ((method? (and (pair? o) (car o)))
(ret-type (parse-type (car func))) (ret-type (parse-type (car func)))
(scheme-name (if (pair? (cadr func)) (caadr func) (cadr func))) (scheme-name (if (pair? (cadr func)) (car (cadr func)) (cadr func)))
(c-name (if (pair? (cadr func)) (c-name (if (pair? (cadr func))
(cadadr func) (cadr (cadr func))
(mangle scheme-name))) (mangle scheme-name)))
(stub-name (if (and (pair? (cadr func)) (pair? (cddadr func))) (stub-name (if (and (pair? (cadr func)) (pair? (cddr (cadr func))))
(car (cddadr func)) (car (cddr (cadr func)))
(generate-stub-name scheme-name)))) (generate-stub-name scheme-name))))
(let lp ((ls (if (equal? (caddr func) '(void)) '() (caddr func))) (let lp ((ls (if (equal? (car (cddr func)) '(void)) '() (car (cddr func))))
(i 0) (i 0)
(results '()) (results '())
(c-args '()) (c-args '())
@ -428,7 +428,7 @@
(er-macro-transformer (er-macro-transformer
(lambda (expr rename compare) (lambda (expr rename compare)
(let ((type (parse-type (cadr expr))) (let ((type (parse-type (cadr expr)))
(name (caddr expr))) (name (car (cddr expr))))
(set! *typedefs* `((,name ,@type) ,@*typedefs*)) (set! *typedefs* `((,name ,@type) ,@*typedefs*))
`(,(rename 'cat) "typedef " ,(type-c-name type) " " ',name ";\n"))))) `(,(rename 'cat) "typedef " ,(type-c-name type) " " ',name ";\n")))))
@ -469,11 +469,11 @@
(lambda (expr rename compare) (lambda (expr rename compare)
(ensure-c++ 'define-c++-method) (ensure-c++ 'define-c++-method)
(let* ((class (cadr expr)) (let* ((class (cadr expr))
(ret-type (caddr expr)) (ret-type (car (cddr expr)))
(name (cadddr expr)) (name (cadr (cddr expr)))
(meths (map (lambda (x) (meths (map (lambda (x)
(parse-func `(,ret-type ,name (,class ,@x)) #t)) (parse-func `(,ret-type ,name (,class ,@x)) #t))
(cddddr expr)))) (cddr (cddr expr)))))
(set! *methods* (cons (cons name meths) *methods*)))))) (set! *methods* (cons (cons name meths) *methods*))))))
;; (define-syntax define-c++-constructor ;; (define-syntax define-c++-constructor
@ -1405,7 +1405,8 @@
((type-struct? (car field)) ((type-struct? (car field))
;; assign to a nested struct - copy field-by-field ;; assign to a nested struct - copy field-by-field
(let ((field-type (let ((field-type
(cond ((lookup-type (type-name (car field))) => cdddr) (cond ((lookup-type (type-name (car field)))
=> (lambda (x) (cddr (cdr x))))
(else (cdr field))))) (else (cdr field)))))
(lambda () (lambda ()
(for-each (for-each
@ -1456,8 +1457,8 @@
(cond (cond
((memq 'constructor: type) ((memq 'constructor: type)
=> (lambda (x) => (lambda (x)
(let ((make (caadr x)) (let ((make (car (cadr x)))
(args (cdadr x))) (args (cdr (cadr x))))
(cat "static sexp " (generate-stub-name make) (cat "static sexp " (generate-stub-name make)
" (sexp ctx, sexp self, sexp_sint_t n" " (sexp ctx, sexp self, sexp_sint_t n"
(lambda () (lambda ()
@ -1524,25 +1525,25 @@
(cond (cond
((and (pair? field) (pair? (cdr field))) ((and (pair? field) (pair? (cdr field)))
(cond (cond
((and (pair? (cddr field)) (caddr field)) ((and (pair? (cddr field)) (car (cddr field)))
(write-type-getter type name field) (write-type-getter type name field)
(set! *funcs* (set! *funcs*
(cons (parse-func (cons (parse-func
`(,(car field) `(,(car field)
(,(caddr field) (,(car (cddr field))
#f #f
,(type-getter-name type name field)) ,(type-getter-name type name field))
(,name))) (,name)))
*funcs*)))) *funcs*))))
(cond (cond
((and (pair? (cddr field)) ((and (pair? (cddr field))
(pair? (cdddr field)) (pair? (cdr (cddr field)))
(car (cdddr field))) (cadr (cddr field)))
(write-type-setter type name field) (write-type-setter type name field)
(set! *funcs* (set! *funcs*
(cons (parse-func (cons (parse-func
`(,(car field) `(,(car field)
(,(car (cdddr field)) (,(cadr (cddr field))
#f #f
,(type-setter-name type name field)) ,(type-setter-name type name field))
(,name ,(car field)))) (,name ,(car field))))
@ -1550,8 +1551,8 @@
(struct-fields type)))) (struct-fields type))))
(define (write-const const) (define (write-const const)
(let ((scheme-name (if (pair? (cadr const)) (caadr const) (cadr const))) (let ((scheme-name (if (pair? (cadr const)) (car (cadr const)) (cadr const)))
(c-name (if (pair? (cadr const)) (cadadr const) (mangle (cadr const))))) (c-name (if (pair? (cadr const)) (cadr (cadr const)) (mangle (cadr const)))))
(cat " name = sexp_intern(ctx, \"" scheme-name "\", " (cat " name = sexp_intern(ctx, \"" scheme-name "\", "
(string-length (x->string scheme-name)) ");\n" (string-length (x->string scheme-name)) ");\n"
" sexp_env_define(ctx, env, name, tmp=" " sexp_env_define(ctx, env, name, tmp="