mirror of
https://github.com/ashinn/chibi-scheme.git
synced 2025-05-19 05:39:18 +02:00
Adding (scheme cxr) library, removing all other references to c[ad]{3,4]r.
This commit is contained in:
Alex Shinn
parent
120a887b3d
commit
c8f13f8538
23 changed files with 117 additions and 140 deletions
|
|
@ -356,11 +356,11 @@
|
|||
;;> Returns the first string cursor of @var{pat} in @var{str},
|
||||
;;> 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
|
||||
;;> be used for brief, deterministic expressions. If used incorrectly
|
||||
;;> (e.g. running an infinite loop) can render the system unusable.
|
||||
;;> Run @var{expr} atomically, disabling yields. Ideally should only be
|
||||
;;> used for brief, deterministic expressions. If used incorrectly (e.g.
|
||||
;;> running an infinite loop) can render the system unusable.
|
||||
;;> Never expose to a sandbox.
|
||||
|
||||
(cond-expand
|
||||
|
|
|
|||
|
|
@ -24,8 +24,8 @@
|
|||
(define-syntax define-method
|
||||
(er-macro-transformer
|
||||
(lambda (e r c)
|
||||
(let ((name (caadr e))
|
||||
(params (cdadr e))
|
||||
(let ((name (car (cadr e)))
|
||||
(params (cdr (cadr e)))
|
||||
(body (cddr e)))
|
||||
`(,(r 'generic-add!) ,name
|
||||
(,(r 'list) ,@(map cadr params))
|
||||
|
|
|
|||
|
|
@ -44,7 +44,7 @@
|
|||
((pair? posns)
|
||||
(lp (cdr ls) (cdr posns) (cons (car posns) args)))
|
||||
(else
|
||||
(lp (cdr ls) posns (cons (cadar ls) args))))))))))))
|
||||
(lp (cdr ls) posns (cons (car (cdar ls)) args))))))))))))
|
||||
. body))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
|
|
|||
|
|
@ -170,7 +170,7 @@
|
|||
(define (mime-header-fold kons knil . o)
|
||||
(let ((src (and (pair? o) (car 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)
|
||||
kons knil (or src (current-input-port)) limit kons-from)))
|
||||
|
||||
|
|
|
|||
|
|
@ -56,9 +56,9 @@
|
|||
(let ((io (open-net-io host service)))
|
||||
(if (not (pair? io))
|
||||
(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-output-port (caddr io))
|
||||
(close-output-port (car (cddr io)))
|
||||
(close-file-descriptor (car io))
|
||||
res))))
|
||||
|
||||
|
|
|
|||
|
|
@ -164,13 +164,13 @@
|
|||
((and (pair? (car ls))
|
||||
(eq? 'mime (caar ls))
|
||||
(pair? (cdar ls))
|
||||
(pair? (cadar ls))
|
||||
(memq (caadar ls) '(^ @)))
|
||||
(let* ((disp0 (mime-ref (cdadar ls) "content-disposition" ""))
|
||||
(pair? (car (cdar ls)))
|
||||
(memq (caar (cdar ls)) '(^ @)))
|
||||
(let* ((disp0 (mime-ref (cdar (cdar ls)) "content-disposition" ""))
|
||||
(disp (mime-parse-content-type disp0))
|
||||
(name (mime-ref disp "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))))
|
||||
(else
|
||||
(lp (cdr ls) res))))
|
||||
|
|
|
|||
|
|
@ -22,7 +22,7 @@
|
|||
(let ((x (find (lambda (r)
|
||||
(and (eq? name (car r)) (eq? lam (cadr r))))
|
||||
cdrs)))
|
||||
(and x (list p f (+ (caddr x) 1)))))
|
||||
(and x (list p f (+ (car (cddr x)) 1)))))
|
||||
(($ Cnd
|
||||
((? (lambda (op) (eq? op pair?))) ($ Ref name (_ . (? lambda? lam))))
|
||||
((? (lambda (op) (eq? op cdr))) ($ Ref name (_ . (? lambda? lam))))
|
||||
|
|
@ -30,7 +30,7 @@
|
|||
(let ((x (find (lambda (r)
|
||||
(and (eq? name (car r)) (eq? lam (cadr r))))
|
||||
cdrs)))
|
||||
(and x (list p f (+ (caddr x) 1.0)))))
|
||||
(and x (list p f (+ (car (cddr x)) 1.0)))))
|
||||
(else #f)))
|
||||
params
|
||||
args))
|
||||
|
|
@ -86,13 +86,13 @@
|
|||
((not r)
|
||||
x)
|
||||
((eq? op car)
|
||||
`(,local-ref ,(+ 1 (inexact->exact (caddr r)))))
|
||||
`(,local-ref ,(+ 1 (inexact->exact (car (cddr r))))))
|
||||
((eq? op cdr)
|
||||
(make-lit '()))
|
||||
((eq? op pair?)
|
||||
`(,> (,num-parameters) ,(+ base (inexact->exact (caddr r)))))
|
||||
`(,> (,num-parameters) ,(+ base (inexact->exact (car (cddr r))))))
|
||||
((eq? op null?)
|
||||
`(,<= (,num-parameters) ,(+ base (inexact->exact (caddr r)))))
|
||||
`(,<= (,num-parameters) ,(+ base (inexact->exact (car (cddr r))))))
|
||||
(else
|
||||
x))))
|
||||
(($ Set ref value)
|
||||
|
|
|
|||
|
|
@ -73,7 +73,7 @@
|
|||
(let ((src (if (pair? o) (car o) (current-input-port)))
|
||||
(start-col (if (and (pair? o) (pair? (cdr o))) (cadr o) 0))
|
||||
(max-col (if (and (pair? o) (pair? (cdr o)) (pair? (cddr o)))
|
||||
(caddr o)
|
||||
(car (cddr o))
|
||||
*default-max-col*)))
|
||||
(qp-encode (if (string? src) src (read-string #f src))
|
||||
start-col max-col "=\r\n")))
|
||||
|
|
@ -85,10 +85,10 @@
|
|||
(let ((src (if (pair? o) (car o) (current-input-port)))
|
||||
(start-col (if (and (pair? o) (pair? (cdr o))) (cadr o) 0))
|
||||
(max-col (if (and (pair? o) (pair? (cdr o)) (pair? (cddr o)))
|
||||
(caddr o)
|
||||
(car (cddr o))
|
||||
*default-max-col*))
|
||||
(nl (if (and (pair? o) (pair? (cdr o)) (pair? (cddr o)) (pair? (cdddr o)))
|
||||
(cadddr o)
|
||||
(nl (if (and (pair? o) (pair? (cdr o)) (pair? (cddr o)) (pair? (cdr (cddr o))))
|
||||
(cadr (cddr o))
|
||||
"\r\n")))
|
||||
(let* ((prefix (string-append "=?" encoding "?Q?"))
|
||||
(prefix-length (+ 2 (string-length prefix)))
|
||||
|
|
|
|||
|
|
@ -11,7 +11,7 @@
|
|||
(for-each
|
||||
(lambda (c)
|
||||
(let ((type (cadr c))
|
||||
(value (caddr c)))
|
||||
(value (car (cddr c))))
|
||||
(hash-table-set! stty-lookup (car c) (cdr c))))
|
||||
|
||||
;; ripped from the stty man page, then trimmed down to what seemed
|
||||
|
|
|
|||
|
|
@ -248,7 +248,7 @@
|
|||
((and (pair? x) (eq? 'call-with-values (car x)))
|
||||
(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)))
|
||||
(cadr x))
|
||||
(- width 3)
|
||||
|
|
|
|||
|
|
@ -35,7 +35,7 @@
|
|||
((and (pair? a) (eq? (car a) 'param-type))
|
||||
(and (pair? b) (eq? (car b) 'param-type)
|
||||
(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? b) (eq? (car b) 'return-type)
|
||||
(eq? (cadr a) (cadr b))))
|
||||
|
|
|
|||
|
|
@ -2,36 +2,10 @@
|
|||
;; Copyright (c) 2009-2011 Alex Shinn. All rights reserved.
|
||||
;; BSD-style license: http://synthcode.com/license.txt
|
||||
|
||||
;; provide c[ad]{2,4}r
|
||||
|
||||
(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 (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
|
||||
|
||||
|
|
@ -155,7 +129,7 @@
|
|||
(list (rename 'if) (rename 'tmp)
|
||||
(if (null? (cdr cl))
|
||||
(rename 'tmp)
|
||||
(list (caddr cl) (rename 'tmp)))
|
||||
(list (car (cddr cl)) (rename 'tmp)))
|
||||
(cons (rename 'cond) (cddr expr))))
|
||||
(car cl))
|
||||
(list (rename 'if)
|
||||
|
|
@ -207,8 +181,8 @@
|
|||
((and (<= d 0) (pair? (car x))
|
||||
(compare (rename 'unquote-splicing) (caar x)))
|
||||
(if (null? (cdr x))
|
||||
(cadar x)
|
||||
(list (rename 'append) (cadar x) (qq (cdr x) d))))
|
||||
(cadr (car x))
|
||||
(list (rename 'append) (cadr (car x)) (qq (cdr x) d))))
|
||||
(else
|
||||
(list (rename 'cons) (qq (car x) d) (qq (cdr x) d)))))
|
||||
((vector? x) (list (rename 'list->vector) (qq (vector->list x) d)))
|
||||
|
|
@ -238,14 +212,14 @@
|
|||
`((,(rename 'lambda) ,vars
|
||||
(,(rename 'letrec) ((,(cadr expr)
|
||||
(,(rename 'lambda) ,vars
|
||||
,@(cdddr expr))))
|
||||
,@(cdr (cddr expr)))))
|
||||
(,(cadr expr) ,@vars)))
|
||||
,@vals)
|
||||
`((,(rename 'lambda) ,vars ,@(cddr expr)) ,@vals)))
|
||||
(map car bindings)
|
||||
(map cadr bindings))
|
||||
(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*
|
||||
(er-macro-transformer
|
||||
|
|
@ -260,8 +234,8 @@
|
|||
(if (pair? x) (if (pair? (cdr x)) (null? (cddr x)) #f) #f))
|
||||
(cadr expr))
|
||||
#f)
|
||||
`(,(rename 'let) (,(caadr expr))
|
||||
(,(rename 'let*) ,(cdadr expr) ,@(cddr expr)))
|
||||
`(,(rename 'let) (,(caar (cdr expr)))
|
||||
(,(rename 'let*) ,(cdar (cdr expr)) ,@(cddr expr)))
|
||||
(error "bad let* syntax"))))))
|
||||
|
||||
(define-syntax case
|
||||
|
|
@ -282,7 +256,7 @@
|
|||
(body (cdar ls)))
|
||||
((and (pair? (car (car ls))) (null? (cdr (car (car ls)))))
|
||||
`(,(rename 'if) (,(rename 'eqv?) ,(rename 'tmp)
|
||||
(,(rename 'quote) ,(caaar ls)))
|
||||
(,(rename 'quote) ,(car (caar ls))))
|
||||
,(body (cdar ls))
|
||||
,(clause (cdr ls))))
|
||||
(else
|
||||
|
|
@ -298,11 +272,11 @@
|
|||
(lambda (expr rename compare)
|
||||
(let* ((body
|
||||
`(,(rename 'begin)
|
||||
,@(cdddr expr)
|
||||
,@(cdr (cddr expr))
|
||||
(,(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)))))
|
||||
(check (caddr expr))
|
||||
(check (car (cddr expr)))
|
||||
(wrap
|
||||
(if (null? (cdr check))
|
||||
`(,(rename 'let) ((,(rename 'tmp) ,(car check)))
|
||||
|
|
@ -637,8 +611,8 @@
|
|||
(_vector->list (rename 'vector->list))
|
||||
(_list->vector (rename 'list->vector)))
|
||||
(define ellipsis (rename (if ellipsis-specified? (cadr expr) '...)))
|
||||
(define lits (if ellipsis-specified? (caddr expr) (cadr expr)))
|
||||
(define forms (if ellipsis-specified? (cdddr expr) (cddr expr)))
|
||||
(define lits (if ellipsis-specified? (car (cddr expr)) (cadr expr)))
|
||||
(define forms (if ellipsis-specified? (cdr (cddr expr)) (cddr expr)))
|
||||
(define (next-symbol s)
|
||||
(set! count (+ count 1))
|
||||
(rename (string->symbol (string-append s (number->string count)))))
|
||||
|
|
|
|||
|
|
@ -91,14 +91,14 @@
|
|||
((not (and (pair? x) (list? x)))
|
||||
(error "invalid module syntax" x))
|
||||
((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))))
|
||||
(cons (car mod-name+imports)
|
||||
(map (lambda (i)
|
||||
(cons ((if (eq? (car x) 'drop-prefix)
|
||||
symbol-drop
|
||||
symbol-append)
|
||||
(caddr x)
|
||||
(car (cddr x))
|
||||
(to-id i))
|
||||
(from-id i)))
|
||||
(cdr mod-name+imports)))))
|
||||
|
|
@ -204,7 +204,7 @@
|
|||
(if (pair? x)
|
||||
(if (and (= 3 (length x))
|
||||
(eq? 'rename (identifier->symbol (car x))))
|
||||
(cons (caddr x) (cadr x))
|
||||
(cons (car (cddr x)) (cadr x))
|
||||
(error "invalid module export" x))
|
||||
x))
|
||||
(set! ,this-module '())
|
||||
|
|
|
|||
|
|
@ -16,9 +16,7 @@
|
|||
bytevector-copy-partial bytevector-copy-partial! bytevector-length
|
||||
bytevector-u8-ref bytevector-u8-set! bytevector? caar cadr
|
||||
call-with-current-continuation call-with-port call-with-values
|
||||
call/cc car case cdr cdar cddr caaar caadr cadar caddr cdaar cdadr cddar
|
||||
cdddr caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr cdaaar
|
||||
cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr ceiling char->integer
|
||||
call/cc car case cdr cdar cddr ceiling char->integer
|
||||
char-ready? char<=? char<? char=? char>=? char>? char?
|
||||
close-input-port close-output-port close-port complex? cond cond-expand
|
||||
cons current-error-port current-input-port current-output-port define
|
||||
|
|
|
|||
|
|
@ -34,14 +34,14 @@
|
|||
|
||||
(define (zip . lists) (apply map list lists))
|
||||
|
||||
(define (unzip1 ls) (map car ls))
|
||||
(define (unzip2 ls) (values (map car ls) (map cadr ls)))
|
||||
(define (unzip3 ls) (values (map car ls) (map cadr ls) (map caddr ls)))
|
||||
(define (unzip1 ls) (map first ls))
|
||||
(define (unzip2 ls) (values (map first ls) (map second ls)))
|
||||
(define (unzip3 ls) (values (map first ls) (map second ls) (map third 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)
|
||||
(values (map car ls) (map cadr ls) (map caddr ls)
|
||||
(map cadddr ls) (map (lambda (x) (car (cddddr x))) ls)))
|
||||
(values (map first ls) (map second ls) (map third ls) (map fourth ls)
|
||||
(map fifth ls)))
|
||||
|
||||
(define (count pred ls . lists)
|
||||
(if (null? lists)
|
||||
|
|
|
|||
|
|
@ -4,8 +4,8 @@
|
|||
|
||||
(define first car)
|
||||
(define second cadr)
|
||||
(define third caddr)
|
||||
(define fourth cadddr)
|
||||
(define (third ls) (car (cdr (cdr ls))))
|
||||
(define (fourth ls) (car (cdr (cdr (cdr ls)))))
|
||||
(define (fifth ls) (car (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))))))))
|
||||
|
|
|
|||
|
|
@ -2,13 +2,15 @@
|
|||
(define-syntax define-record-type
|
||||
(er-macro-transformer
|
||||
(lambda (expr rename compare)
|
||||
(let* ((name (if (pair? (cadr expr)) (caadr expr) (cadr expr)))
|
||||
(parent (and (pair? (cadr expr)) (cadadr expr)))
|
||||
(let* ((name+parent (cadr 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)))
|
||||
(make (caaddr expr))
|
||||
(make-fields (cdaddr expr))
|
||||
(pred (cadddr expr))
|
||||
(fields (cddddr expr))
|
||||
(procs (cddr expr))
|
||||
(make (caar procs))
|
||||
(make-fields (cdar procs))
|
||||
(pred (cadr procs))
|
||||
(fields (cddr procs))
|
||||
(_define (rename 'define))
|
||||
(_lambda (rename 'lambda))
|
||||
(_let (rename 'let))
|
||||
|
|
@ -34,10 +36,10 @@
|
|||
fields)
|
||||
,@(map (lambda (f)
|
||||
(and (pair? f) (pair? (cdr f)) (pair? (cddr f))
|
||||
`(,_define ,(caddr f)
|
||||
`(,_define ,(car (cddr f))
|
||||
(,(rename 'make-setter)
|
||||
,(symbol->string
|
||||
(identifier->symbol (caddr f)))
|
||||
(identifier->symbol (car (cddr f))))
|
||||
,name
|
||||
(,_type_slot_offset ,name ',(car f))))))
|
||||
fields)
|
||||
|
|
@ -60,7 +62,7 @@
|
|||
(error "unknown record field in constructor" (car ls)))
|
||||
((pair? (cddr field))
|
||||
(lp (cdr ls)
|
||||
(cons `(,(caddr field) res ,(car ls)) sets)))
|
||||
(cons `(,(car (cddr field)) res ,(car ls)) sets)))
|
||||
(else
|
||||
(lp (cdr ls)
|
||||
(cons `(,_slot-set! ,name res (,_type_slot_offset ,name ',(car ls)) ,(car ls))
|
||||
|
|
|
|||
|
|
@ -29,6 +29,6 @@
|
|||
(rtd-field-mutable? p x)
|
||||
(error "unknown field" rtd x))))
|
||||
((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))))
|
||||
(else (lp (cdr ls))))))
|
||||
|
|
|
|||
|
|
@ -26,7 +26,7 @@
|
|||
(let lp ((i 0) (ls ls))
|
||||
(cond ((null? ls ) #f)
|
||||
((if (pair? (car ls))
|
||||
(eq? field (cadar ls))
|
||||
(eq? field (car (cdar ls)))
|
||||
(eq? field (car ls)))
|
||||
i)
|
||||
(else (lp (+ i 1) (cdr ls))))))
|
||||
|
|
|
|||
|
|
@ -3,18 +3,20 @@
|
|||
(er-macro-transformer
|
||||
(lambda (expr rename compare)
|
||||
(let* ((id->string (lambda (x) (symbol->string (identifier->symbol x))))
|
||||
(name (if (pair? (cadr expr)) (caadr expr) (cadr expr)))
|
||||
(parent (and (pair? (cadr expr)) (cadadr expr)))
|
||||
(name+parent (cadr expr))
|
||||
(name (if (pair? name+parent) (car name+parent) name+parent))
|
||||
(parent (and (pair? name+parent) (cadr name+parent)))
|
||||
(name-str (id->string name))
|
||||
(make (caddr expr))
|
||||
(procs (cddr expr))
|
||||
(make (car procs))
|
||||
(make-name (if (eq? make #t)
|
||||
(string->symbol (string-append "make-" name-str))
|
||||
(if (pair? make) (car make) make)))
|
||||
(pred (cadddr expr))
|
||||
(pred (cadr procs))
|
||||
(pred-name (if (eq? pred #t)
|
||||
(string->symbol (string-append name-str "?"))
|
||||
pred))
|
||||
(fields (cddddr expr))
|
||||
(fields (cddr procs))
|
||||
(field-names (map (lambda (x) (if (pair? x) (car x) x)) fields))
|
||||
(make-fields (if (pair? make) (cdr make) (and (not parent) field-names)))
|
||||
(_define (rename 'define))
|
||||
|
|
@ -51,7 +53,7 @@
|
|||
fields)
|
||||
,@(map (lambda (f)
|
||||
(let ((s (if (and (pair? f) (pair? (cdr f)) (pair? (cddr f)))
|
||||
(caddr f)
|
||||
(car (cddr f))
|
||||
(and (identifier? f)
|
||||
(string->symbol
|
||||
(string-append name-str "-" (id->string f) "-set!"))))))
|
||||
|
|
@ -82,7 +84,7 @@
|
|||
;; (error "unknown record field in constructor" (car ls)))
|
||||
((and (pair? field) (pair? (cdr field)) (pair? (cddr field)))
|
||||
(lp (cdr ls)
|
||||
(cons (list (caddr field) 'res (car ls)) sets)))
|
||||
(cons (list (car (cddr field)) 'res (car ls)) sets)))
|
||||
(else
|
||||
(lp (cdr ls)
|
||||
(cons `(,_slot-set! ,name res (,_type_slot_offset ,name ',(car ls)) ,(car ls)) sets)))))))))
|
||||
|
|
|
|||
|
|
@ -5,9 +5,9 @@
|
|||
(let ((condition
|
||||
(make-syntactic-closure environment '() (cadr form)))
|
||||
(consequent
|
||||
(make-syntactic-closure environment '(it) (caddr form)))
|
||||
(make-syntactic-closure environment '(it) (car (cddr form))))
|
||||
(alternative
|
||||
(make-syntactic-closure environment '() (cadddr form))))
|
||||
(make-syntactic-closure environment '() (cadr (cddr form)))))
|
||||
`(let ((it ,condition))
|
||||
(if it
|
||||
,consequent
|
||||
|
|
|
|||
|
|
@ -90,7 +90,7 @@
|
|||
|
||||
(define (sxml-body 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))))
|
||||
|
||||
(define (env-ref env name . o)
|
||||
|
|
@ -165,9 +165,9 @@
|
|||
(error "section must not be empty" sxml)
|
||||
(let* ((name (and (eq? 'tag: (cadr sxml))
|
||||
(pair? (cddr sxml))
|
||||
(sxml-strip (caddr sxml))))
|
||||
(sxml-strip (car (cddr sxml)))))
|
||||
(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)))))
|
||||
`(div (a (^ (name . ,(section-name tag name)))) (,tag ,@body))))))
|
||||
|
||||
|
|
@ -195,10 +195,10 @@
|
|||
|
||||
(define (expand-code sxml env)
|
||||
(let* ((hl (if (and (pair? (cdr sxml)) (eq? 'language: (cadr sxml)))
|
||||
(highlighter-for (caddr sxml))
|
||||
(highlighter-for (car (cddr sxml)))
|
||||
highlight))
|
||||
(body (if (and (pair? (cdr sxml)) (eq? 'language: (cadr sxml)))
|
||||
(cdddr sxml)
|
||||
(cdr (cddr sxml))
|
||||
(cdr sxml))))
|
||||
`(code ,@(map-sxml (lambda (x) (if (string? x) (hl x) x))
|
||||
(normalize-sxml
|
||||
|
|
@ -274,7 +274,7 @@
|
|||
(if (null? 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)
|
||||
(cons `(li ,parent ,(get-contents (reverse kids))) res))
|
||||
(cond
|
||||
|
|
@ -283,7 +283,7 @@
|
|||
((> (caar ls) d)
|
||||
(lp (cdr ls) parent (cons (car ls) kids) res))
|
||||
(else
|
||||
(lp (cdr ls) (cadar ls) '() (collect))))))))
|
||||
(lp (cdr ls) (car (cdar ls)) '() (collect))))))))
|
||||
|
||||
(define (fix-header x)
|
||||
`(html (head ,@(cond ((assq 'title x) => (lambda (x) (list x)))
|
||||
|
|
@ -351,7 +351,7 @@ div#footer {padding-bottom: 50px}
|
|||
(skip-whitespace in))))
|
||||
|
||||
(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)
|
||||
(match form
|
||||
|
|
@ -388,10 +388,10 @@ div#footer {padding-bottom: 50px}
|
|||
(cons (if (pair? (cadr ls)) (cadr ls) (list (cadr ls))) res)))
|
||||
((pair? (car ls))
|
||||
(lp (cdr ls)
|
||||
(append (if (pair? (cdddar ls))
|
||||
(list (list (car (cdddar ls)) name (caar ls)))
|
||||
(append (if (pair? (cddr (cdar ls)))
|
||||
(list (list (car (cddr (cdar ls))) name (caar ls)))
|
||||
'())
|
||||
(list (list (caddar ls) name))
|
||||
(list (list (cadr (cdar ls)) name))
|
||||
res)))
|
||||
((symbol? (car ls))
|
||||
(lp (cddr ls) res))
|
||||
|
|
@ -433,7 +433,7 @@ div#footer {padding-bottom: 50px}
|
|||
orig-ls)
|
||||
(else
|
||||
(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 '()))
|
||||
(cond
|
||||
((or (null? ls)
|
||||
|
|
@ -448,8 +448,8 @@ div#footer {padding-bottom: 50px}
|
|||
tag: ,(write-to-string name)
|
||||
(rawcode
|
||||
,@(if (eq? 'const: (caar sig))
|
||||
`((i ,(write-to-string (cadar sig)) ": ")
|
||||
,(write-to-string (caddar sig)))
|
||||
`((i ,(write-to-string (car (cdar sig))) ": ")
|
||||
,(write-to-string (cadr (cdar sig))))
|
||||
(intersperse (map write-to-string sig) '(br)))))))
|
||||
,@ls))
|
||||
(else
|
||||
|
|
@ -459,10 +459,10 @@ div#footer {padding-bottom: 50px}
|
|||
(call-with-input-file file
|
||||
(lambda (in)
|
||||
(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
|
||||
(lambda (x)
|
||||
(and (pair? (caddr x)) (equal? file (caaddr x))))
|
||||
(and (pair? (third x)) (equal? file (car (third x)))))
|
||||
defs))))
|
||||
(let lp ((lines '()) (cur '()) (res '()))
|
||||
(define (collect)
|
||||
|
|
@ -503,14 +503,14 @@ div#footer {padding-bottom: 50px}
|
|||
(line1 (port-line in))
|
||||
(x (read in))
|
||||
(line2 (port-line in))
|
||||
(procs (filter (lambda (x) (<= line1 (caddr x) line2))
|
||||
(filter caddr defs))))
|
||||
(procs (filter (lambda (x) (<= line1 (third x) line2))
|
||||
(filter third defs))))
|
||||
(cond
|
||||
((and (eq? lang 'ffi) (get-ffi-signatures x))
|
||||
=> (lambda (sigs)
|
||||
(let ((sigs (filter
|
||||
(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)))
|
||||
(lp '() '() (append (insert-signature cur #f sigs) res)))))
|
||||
((and (eq? lang 'scheme) (= 1 (length procs)))
|
||||
|
|
|
|||
|
|
@ -72,7 +72,7 @@
|
|||
((result)
|
||||
(lp (next) free? const? null-ptr? ptr? ref? struct? link? #t array value default? template))
|
||||
((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)
|
||||
(lp (cddr type) free? const? null-ptr? ref? ptr? struct? link? result? array (cadr type) default? template))
|
||||
((default)
|
||||
|
|
@ -123,7 +123,7 @@
|
|||
(let lp ((ls (struct-fields (cdr x))))
|
||||
(cond
|
||||
((null? ls) #f)
|
||||
((eq? field (caar ls)) (cadar ls))
|
||||
((eq? field (caar ls)) (car (cdar ls)))
|
||||
(else (lp (cdr ls)))))))
|
||||
(else
|
||||
#f)))
|
||||
|
|
@ -190,18 +190,18 @@
|
|||
(<= 1 (length (cadr func)) 3)
|
||||
(every (lambda (x) (or (identifier? x) (not x) (string? x)))
|
||||
(cadr func))))
|
||||
(list? (caddr func))))
|
||||
(list? (car (cddr func)))))
|
||||
(error "bad function definition" func))
|
||||
(let* ((method? (and (pair? o) (car o)))
|
||||
(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))
|
||||
(cadadr func)
|
||||
(cadr (cadr func))
|
||||
(mangle scheme-name)))
|
||||
(stub-name (if (and (pair? (cadr func)) (pair? (cddadr func)))
|
||||
(car (cddadr func))
|
||||
(stub-name (if (and (pair? (cadr func)) (pair? (cddr (cadr func))))
|
||||
(car (cddr (cadr func)))
|
||||
(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)
|
||||
(results '())
|
||||
(c-args '())
|
||||
|
|
@ -428,7 +428,7 @@
|
|||
(er-macro-transformer
|
||||
(lambda (expr rename compare)
|
||||
(let ((type (parse-type (cadr expr)))
|
||||
(name (caddr expr)))
|
||||
(name (car (cddr expr))))
|
||||
(set! *typedefs* `((,name ,@type) ,@*typedefs*))
|
||||
`(,(rename 'cat) "typedef " ,(type-c-name type) " " ',name ";\n")))))
|
||||
|
||||
|
|
@ -469,11 +469,11 @@
|
|||
(lambda (expr rename compare)
|
||||
(ensure-c++ 'define-c++-method)
|
||||
(let* ((class (cadr expr))
|
||||
(ret-type (caddr expr))
|
||||
(name (cadddr expr))
|
||||
(ret-type (car (cddr expr)))
|
||||
(name (cadr (cddr expr)))
|
||||
(meths (map (lambda (x)
|
||||
(parse-func `(,ret-type ,name (,class ,@x)) #t))
|
||||
(cddddr expr))))
|
||||
(cddr (cddr expr)))))
|
||||
(set! *methods* (cons (cons name meths) *methods*))))))
|
||||
|
||||
;; (define-syntax define-c++-constructor
|
||||
|
|
@ -1405,7 +1405,8 @@
|
|||
((type-struct? (car field))
|
||||
;; assign to a nested struct - copy field-by-field
|
||||
(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)))))
|
||||
(lambda ()
|
||||
(for-each
|
||||
|
|
@ -1456,8 +1457,8 @@
|
|||
(cond
|
||||
((memq 'constructor: type)
|
||||
=> (lambda (x)
|
||||
(let ((make (caadr x))
|
||||
(args (cdadr x)))
|
||||
(let ((make (car (cadr x)))
|
||||
(args (cdr (cadr x))))
|
||||
(cat "static sexp " (generate-stub-name make)
|
||||
" (sexp ctx, sexp self, sexp_sint_t n"
|
||||
(lambda ()
|
||||
|
|
@ -1524,25 +1525,25 @@
|
|||
(cond
|
||||
((and (pair? field) (pair? (cdr field)))
|
||||
(cond
|
||||
((and (pair? (cddr field)) (caddr field))
|
||||
((and (pair? (cddr field)) (car (cddr field)))
|
||||
(write-type-getter type name field)
|
||||
(set! *funcs*
|
||||
(cons (parse-func
|
||||
`(,(car field)
|
||||
(,(caddr field)
|
||||
(,(car (cddr field))
|
||||
#f
|
||||
,(type-getter-name type name field))
|
||||
(,name)))
|
||||
*funcs*))))
|
||||
(cond
|
||||
((and (pair? (cddr field))
|
||||
(pair? (cdddr field))
|
||||
(car (cdddr field)))
|
||||
(pair? (cdr (cddr field)))
|
||||
(cadr (cddr field)))
|
||||
(write-type-setter type name field)
|
||||
(set! *funcs*
|
||||
(cons (parse-func
|
||||
`(,(car field)
|
||||
(,(car (cdddr field))
|
||||
(,(cadr (cddr field))
|
||||
#f
|
||||
,(type-setter-name type name field))
|
||||
(,name ,(car field))))
|
||||
|
|
@ -1550,8 +1551,8 @@
|
|||
(struct-fields type))))
|
||||
|
||||
(define (write-const const)
|
||||
(let ((scheme-name (if (pair? (cadr const)) (caadr const) (cadr const)))
|
||||
(c-name (if (pair? (cadr const)) (cadadr const) (mangle (cadr const)))))
|
||||
(let ((scheme-name (if (pair? (cadr const)) (car (cadr const)) (cadr const)))
|
||||
(c-name (if (pair? (cadr const)) (cadr (cadr const)) (mangle (cadr const)))))
|
||||
(cat " name = sexp_intern(ctx, \"" scheme-name "\", "
|
||||
(string-length (x->string scheme-name)) ");\n"
|
||||
" sexp_env_define(ctx, env, name, tmp="
|
||||
|
|
|
|||
Loading…
Add table
Reference in a new issue