Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
tree: 6627e22274
Fetching contributors…

Cannot retrieve contributors at this time

354 lines (291 sloc) 10.602 kB
(use ar)
(ail-code (ar-def ar-extend-impl (name test body)
(racket-let ((previous (ar-var name)))
(ar-assign name
(racket-lambda args
(racket-let ((result (racket-apply test args)))
(racket-if (ar-true result)
(racket-apply body args)
(racket-apply previous args))))))))
(ail-code (racket-define-syntax-rule (ar-extend name args test body racket-...)
(ar-extend-impl (racket-quote name)
(racket-lambda args test)
(racket-lambda args body racket-...))))
(ail-code (ar-def ac-literal? (x)
(ar-tnil
(racket-or (racket-char? x)
(racket-string? x)
(racket-number? x)
(racket-procedure? x)))))
(ail-code (ar-extend ac (s env)
(ac-literal? s)
s))
(ail-code (ar-def ar-mem (v lst)
(ar-tnil
(racket-and (racket-mpair? lst)
(racket-or (ar-true (is v (car lst)))
(ar-true (ar-mem v (cdr lst))))))))
(ail-code (ar-def ac-lex? (v env)
(ar-mem v env)))
(ail-code (ar-def ac-global (v)
v))
(ail-code (ar-extend ac (s env)
(ar-tnil (racket-symbol? s))
(racket-if (ar-true (ac-lex? s env))
s
(ac-global s))))
(ail-code (ar-def ac-args (names exprs env)
(map1 (racket-lambda (expr)
(ac expr env))
exprs)))
(ail-code (ar-def ac-call (f args env)
(racket-cond
;; if we're about to call a literal fn such as ((fn (a b) ...) 1 2)
;; then we know we can just call it in Racket and we don't
;; have to use ar-apply
((racket-and (racket-mpair? f) (racket-eq? (car f) (racket-quote fn)))
(cons (ac f env)
(ac-args (cadr f) args env)))
(racket-else
(cons (racket-case (len args)
((0) ar-funcall0)
((1) ar-funcall1)
((2) ar-funcall2)
((3) ar-funcall3)
((4) ar-funcall4)
(racket-else ar-apply))
(cons (ac f env)
(map1 (racket-lambda (arg) (ac arg env)) args)))))))
(ail-code (ar-extend ac (s env)
(ar-tnil
(racket-and (racket-mpair? s)
(racket-not (ar-true (is (car s) (racket-quote ail-code))))
(racket-not (ar-true (is (car s) (racket-quote use))))))
(ac-call (car s) (cdr s) env)))
;; quote
; The goal here is to get the quoted value tunneled through Racket's
; compiler unscathed. This trick uses rocketnia's method: Racket
; doesn't copy function values.
(ail-code (ar-extend ac (s env) (caris s (racket-quote quote))
(racket-let ((v (cadr s)))
(list (list (racket-quote racket-quote) (racket-lambda () v))))))
(ail-code (ar-def ac-body (body env)
(map1 (racket-lambda (x) (ac x env)) body)))
(ail-code (ar-def ac-body* (body env)
(racket-if (ar-no body)
(list nil)
(ac-body body env))))
(ail-code (ar-def ac-arglist (a)
(racket-cond
((ar-no a) nil)
((racket-symbol? a) (list a))
((racket-and (racket-symbol? (cdr a))
(racket-not (ar-no (cdr a))))
(list (car a) (cdr a)))
(racket-else (cons (car a) (ac-arglist (cdr a)))))))
(ail-code (ar-def ac-body*x (args body env)
(ac-body* body (join (ac-arglist args) env))))
(ail-code (ar-def ac-dotted-list? (x)
(racket-cond
((racket-and (racket-symbol? x) (ar-true x))
t)
((racket-mpair? x)
(ac-dotted-list? (cdr x)))
(racket-else
nil))))
; Rest args, optional args, and arg list destructuring are implemented
; later.
(ail-code (ar-def ac-fn (args body env)
(racket-if (ar-true (ac-dotted-list? args))
(ac-fn-rest args body env)
(racket-mcons (racket-quote racket-lambda)
(racket-mcons (ar-tunnel (ar-list-fromarc args))
(ac-body*x args body env))))))
(ail-code (ar-extend ac (s env)
(caris s (racket-quote ar-fn))
(ac-fn (cadr s) (cddr s) env)))
;; quasiquotation
; qq-expand takes an Arc list containing a quasiquotation expression
; (the x in `x), and returns an Arc list containing Arc code. The Arc
; code, when evaled by Arc, will construct an Arc list, the
; expansion of the quasiquotation expression.
; This implementation is Alan Bawden's quasiquotation expansion
; algorithm from "Quasiquotation in Lisp"
; http://repository.readscheme.org/ftp/papers/pepm99/bawden.pdf
; You can redefine qq-expand in Arc if you want to implement a
; different expansion algorithm.
(ail-code (ar-def qq-expand (x)
(racket-cond
((ar-true (caris x (racket-quote unquote)))
(cadr x))
((ar-true (caris x (racket-quote unquote-splicing)))
(err "illegal use of ,@ in non-list quasiquote expansion"))
((ar-true (caris x (racket-quote quasiquote)))
(qq-expand (qq-expand (cadr x))))
((racket-mpair? x)
(qq-expand-pair x))
(racket-else
(list (racket-quote quote) x)))))
(ail-code (ar-def qq-expand-pair (x)
(list (racket-quote join)
(qq-expand-list (car x))
(qq-expand (cdr x)))))
(ail-code (ar-def qq-expand-list (x)
(racket-cond
((ar-true (caris x (racket-quote unquote)))
(list (racket-quote list) (cadr x)))
((ar-true (caris x (racket-quote unquote-splicing)))
(cadr x))
((ar-true (caris x (racket-quote quasiquote)))
(qq-expand-list (qq-expand (cadr x))))
((racket-mpair? x)
(list (racket-quote list) (qq-expand-pair x)))
(racket-else
(list (racket-quote quote) (list x))))))
(ail-code (ar-extend ac (s env)
(caris s (racket-quote quasiquote))
(racket-let ((expansion (qq-expand (cadr s))))
(ac expansion env))))
(ail-code (ar-def ac-if (args env)
(racket-cond
((ar-no args)
nil)
((ar-no (cdr args))
(ac (car args) env))
(racket-else
(list (racket-quote racket-if)
(list ar-true (ac (car args) env))
(ac (cadr args) env)
(ac-if (cddr args) env))))))
(ail-code (ar-extend ac (s env)
(caris s (racket-quote if))
(ac-if (cdr s) env)))
(ail-code (ar-def ac-global-assign (a b)
(list (racket-quote racket-set!) a b)))
(ail-code (ar-def ac-assign1 (a b1 env)
(racket-unless (racket-symbol? a)
(err "First arg to assign must be a symbol" a))
(racket-let ((result (uniq)))
(list (racket-quote racket-let)
(list (list result (ac b1 env)))
(racket-if (ar-true (ac-lex? a env))
(list (racket-quote racket-set!) a result)
(ac-global-assign a result))
result))))
(ail-code (ar-def ac-assignn (x env)
(racket-if (ar-no x)
nil
;; todo: why does Arc 3.1 call ac-macex here?
(cons (ac-assign1 (car x) (cadr x) env)
(ac-assignn (cddr x) env)))))
(ail-code (ar-def ac-assign (x env)
(cons (racket-quote racket-begin)
(ac-assignn x env))))
(ail-code (ar-extend ac (s env)
(caris s (racket-quote assign))
(ac-assign (cdr s) env)))
(ail-code (ar-def ac-macro? (fn)
(racket-cond
((ar-true (is (type fn) (racket-quote mac)))
(rep fn))
((racket-symbol? fn)
(racket-let ((v (ar-var fn nil)))
(racket-if (ar-true (is (type v) (racket-quote mac)))
(rep v)
nil)))
(racket-else
nil))))
(ail-code (ar-def ac-mac-call (m args env)
(ac (apply m args) env)))
(ail-code (ar-extend ac-call (fn args env)
(racket-if (ar-true (ac-lex? fn env))
nil
(ac-macro? fn))
(ac-mac-call (ac-macro? fn) args env)))
(ail-code (ar-def ac-rest-param (x)
(racket-cond
((racket-and (racket-symbol? x) (ar-true x))
x)
((racket-mpair? x)
(ac-rest-param (cdr x)))
(racket-else
(err "not a dotted list")))))
(ail-code (ar-def ac-args-without-rest (x)
(racket-cond
((racket-mpair? x)
(join (list (car x)) (ac-args-without-rest (cdr x))))
(racket-else
nil))))
(ail-code (racket-hash-set! sig (racket-quote ac-fn-rest-impl)
(ar-toarc (racket-quote (args r/rest rest body env)))))
(ail-code (racket-define ac-fn-rest-impl
(eval (ar-toarc (racket-quote
(ar-fn (args r/rest rest body env)
`(racket-lambda ,(join args r/rest)
(racket-let ((,rest (,ar-r/list-toarc ,r/rest)))
,@(ac-body*x (join args (list rest)) body env)))))))))
(ail-code (ar-def ac-fn-rest (args body env)
(ac-fn-rest-impl
(ac-args-without-rest args)
(uniq)
(ac-rest-param args)
body
env)))
(ail-code (racket-hash-set! sig (racket-quote bound)
(ar-toarc (racket-quote (name)))))
(ail-code (racket-define bound
(racket-let ((undef (list (racket-quote undef))))
(racket-lambda (name)
(ar-tnil
(racket-not (racket-eq? (ar-var name undef) undef)))))))
(ail-code (ar-def ar-tostringf (f)
(racket-let ((port (racket-open-output-string)))
(racket-parameterize ((racket-current-output-port port))
(f))
(racket-get-output-string port))))
(ail-code (racket-hash-set! sig (racket-quote ar-disp)
(ar-toarc (racket-quote (x (o port stdout))))))
(ail-code (racket-define (ar-disp x (port (racket-current-output-port)))
(racket-display x port)
(racket-flush-output port)
x))
(ail-code (racket-hash-set! sig (racket-quote ar-write)
(ar-toarc (racket-quote (x (o port stdout))))))
(ail-code (racket-define (ar-write x (port (racket-current-output-port)))
(racket-write x port)
(racket-flush-output port)
x))
(ail-code (racket-hash-set! sig (racket-quote table)
(ar-toarc (racket-quote ((o init))))))
(ail-code (racket-define (table (init nil))
(racket-let ((h (racket-make-hash)))
(racket-when (ar-true init) (init h))
h)))
(ail-code (ar-def sref (com val ind)
(racket-cond
((racket-hash? com)
(racket-if (ar-no val)
(racket-hash-remove! com ind)
(racket-hash-set! com ind val)))
((racket-string? com)
(racket-string-set! com ind val))
((racket-mpair? com)
(racket-set-mcar! (racket-mlist-tail com ind) val))
(racket-else
(err "Can't set reference" com ind val)))
val))
(ail-code (ar-def on-err (errf f)
(racket-with-handlers ((racket-exn:fail? errf))
(f))))
(ail-code (ar-def details (c)
(racket-exn-message c)))
(ail-code (ar-def parameter (init)
(racket-make-parameter init)))
(ail-code (ar-def ar-read-square-brackets (ch port src line col pos)
(racket-quasiquote
(square-bracket
(racket-unquote-splicing (racket-read/recursive port #\[ #f))))))
(ail-code (ar-def ar-bracket-readtable (readtable)
(racket-make-readtable readtable #\[ (racket-quote terminating-macro)
ar-read-square-brackets)))
(ail-code (racket-define arc-readtable* (ar-bracket-readtable #f)))
Jump to Line
Something went wrong with that request. Please try again.