Permalink
Browse files

arc3.1.tar

  • Loading branch information...
1 parent aaccf34 commit f01d3f9c661eed05511711a0f3388ca2a1d34fa2 pg and rtm committed with rntz Aug 4, 2009
Showing with 164 additions and 75 deletions.
  1. +70 −17 ac.scm
  2. +35 −21 app.arc
  3. +4 −3 arc.arc
  4. +2 −2 how-to-run-news
  5. +6 −2 html.arc
  6. +35 −28 news.arc
  7. +2 −1 srv.arc
  8. BIN static/arc.png
  9. +10 −1 strings.arc
View
87 ac.scm
@@ -3,12 +3,11 @@
(module ac mzscheme
(provide (all-defined))
-; uncomment the following require for mzscheme-4.x
-; much of Arc will work, but not mutable pairs.
-; (require rnrs/mutable-pairs-6)
(require (lib "port.ss"))
(require (lib "process.ss"))
(require (lib "pretty.ss"))
+(require (lib "foreign.ss"))
+(unsafe!)
; compile an Arc expression into a Scheme expression,
; both represented as s-expressions.
@@ -68,7 +67,7 @@
(and (>= i 0)
(or (let ((c (string-ref string i)))
(or (eqv? c #\:) (eqv? c #\~)
- (eqv? c #\+)
+ (eqv? c #\&)
;(eqv? c #\_)
(eqv? c #\.) (eqv? c #\!)))
(has-ssyntax-char? string (- i 1)))))
@@ -83,15 +82,15 @@
; because then _!foo becomes a function. Maybe use <>. For now
; leave this off and see how often it would have been useful.
-; Might want to make ~ have less precedence than +, because
-; ~foo+bar prob should mean (andf (complement foo) bar), not
+; Might want to make ~ have less precedence than &, because
+; ~foo&bar prob should mean (andf (complement foo) bar), not
; (complement (andf foo bar)).
(define (expand-ssyntax sym)
((cond ((or (insym? #\: sym) (insym? #\~ sym)) expand-compose)
- ((insym? #\+ sym) expand-and)
- ; ((insym? #\_ sym) expand-curry)
((or (insym? #\. sym) (insym? #\! sym)) expand-sexpr)
+ ((insym? #\& sym) expand-and)
+ ; ((insym? #\_ sym) expand-curry)
(#t (error "Unknown ssyntax" sym)))
sym))
@@ -113,7 +112,7 @@
(define (expand-and sym)
(let ((elts (map chars->value
- (tokens (lambda (c) (eqv? c #\+))
+ (tokens (lambda (c) (eqv? c #\&))
(symbol->chars sym)
'()
'()
@@ -238,9 +237,18 @@
((and (pair? x) (eqv? (car x) 'quasiquote))
(list 'quasiquote (ac-qq1 (+ level 1) (cadr x) env)))
((pair? x)
- (map (lambda (x) (ac-qq1 level x env)) x))
+ (imap (lambda (x) (ac-qq1 level x env)) x))
(#t x)))
+; like map, but don't demand '()-terminated list
+
+(define (imap f l)
+ (cond ((pair? l)
+ (cons (f (car l)) (imap f (cdr l))))
+ ((null? l)
+ '())
+ (#t (f l))))
+
; (if) -> nil
; (if x) -> x
; (if t a ...) -> a
@@ -815,6 +823,8 @@
; (type nil) -> sym
+(define (exint? x) (and (integer? x) (exact? x)))
+
(define (ar-type x)
(cond ((ar-tagged? x) (vector-ref x 1))
((pair? x) 'cons)
@@ -823,7 +833,7 @@
((procedure? x) 'fn)
((char? x) 'char)
((string? x) 'string)
- ((integer? x) 'int)
+ ((exint? x) 'int)
((number? x) 'num) ; unsure about this
((hash-table? x) 'table)
((output-port? x) 'output)
@@ -950,7 +960,7 @@
((string) (string x))
((sym) (string->symbol (string x)))
(else (err "Can't coerce" x type))))
- ((integer? x) (case type
+ ((exint? x) (case type
((num) x)
((char) (ascii->char x))
((string) (apply number->string x args))
@@ -1008,6 +1018,11 @@
(let-values (((us them) (tcp-addresses out)))
them))))))))
+; allow Arc to give up root privileges after it
+; calls open-socket. thanks, Eli!
+(define setuid (get-ffi-obj 'setuid #f (_fun _int -> _int)))
+(xdef setuid setuid)
+
(xdef new-thread thread)
(xdef kill-thread kill-thread)
(xdef break-thread break-thread)
@@ -1216,15 +1231,52 @@
(xdef scar (lambda (x val)
(if (string? x)
(string-set! x 0 val)
- (set-car! x val))
+ (x-set-car! x val))
val))
(xdef scdr (lambda (x val)
(if (string? x)
(err "Can't set cdr of a string" x)
- (set-cdr! x val))
+ (x-set-cdr! x val))
val))
+; decide at run-time whether the underlying mzscheme supports
+; set-car! and set-cdr!, since I can't figure out how to do it
+; at compile time.
+
+(define (x-set-car! p v)
+ (let ((fn (namespace-variable-value 'set-car! #t (lambda () #f))))
+ (if (procedure? fn)
+ (fn p v)
+ (n-set-car! p v))))
+
+(define (x-set-cdr! p v)
+ (let ((fn (namespace-variable-value 'set-cdr! #t (lambda () #f))))
+ (if (procedure? fn)
+ (fn p v)
+ (n-set-cdr! p v))))
+
+; Eli's code to modify mzscheme-4's immutable pairs.
+
+;; to avoid a malloc on every call, reuse a single pointer, but make
+;; it thread-local to avoid races
+(define ptr (make-thread-cell #f))
+(define (get-ptr)
+ (or (thread-cell-ref ptr)
+ (let ([p (malloc _scheme 1)]) (thread-cell-set! ptr p) p)))
+
+;; set a pointer to the cons cell, then dereference it as a pointer,
+;; and bang the new value in the given offset
+(define (set-ca/dr! offset who p x)
+ (if (pair? p)
+ (let ([p* (get-ptr)])
+ (ptr-set! p* _scheme p)
+ (ptr-set! (ptr-ref p* _pointer 0) _scheme offset x))
+ (raise-type-error who "pair" p)))
+
+(define (n-set-car! p x) (set-ca/dr! 1 'set-car! p x))
+(define (n-set-cdr! p x) (set-ca/dr! 2 'set-cdr! p x))
+
; When and if cdr of a string returned an actual (eq) tail, could
; say (if (string? x) (string-replace! x val 1) ...) in scdr, but
; for now would be misleading to allow this, because fails for cddr.
@@ -1249,7 +1301,7 @@
val))
(define (nth-set! lst n val)
- (set-car! (list-tail lst n) val))
+ (x-set-car! (list-tail lst n) val))
; rewrite to pass a (true) gensym instead of #f in case var bound to #f
@@ -1264,8 +1316,9 @@
(xdef trunc (lambda (x) (inexact->exact (truncate x))))
-(xdef exact (lambda (x)
- (tnil (and (integer? x) (exact? x)))))
+; bad name
+
+(xdef exact (lambda (x) (tnil (exint? x))))
(xdef msec current-milliseconds)
(xdef current-process-milliseconds current-process-milliseconds)
View
56 app.arc
@@ -373,28 +373,42 @@
date (or (errsafe (parse-date str)) fail)
(err "unknown readvar type" typ)))
-(= fail* (uniq))
+; dates should be tagged date, and just redefine <
+
+(def varcompare (typ)
+ (if (in typ 'syms 'sexpr 'users 'toks 'bigtoks 'lines 'hexcol)
+ (fn (x y) (> (len x) (len y)))
+ (is typ 'date)
+ (fn (x y)
+ (or (no y) (and x (date< x y))))
+ (fn (x y)
+ (or (empty y) (and (~empty x) (< x y))))))
+
+
+; (= fail* (uniq))
+
+(def fail* ()) ; coudn't possibly come back from a form
; Takes a list of fields of the form (type label value view modify) and
; a fn f and generates a form such that when submitted (f label newval)
; will be called for each valid value. Finally done is called.
(def vars-form (user fields f done (o button "update") (o lasts))
- (timed-aform lasts
- (if (all [no (_ 4)] fields)
- (fn (req))
- (fn (req)
- (when-umatch user req
- (each (k v) req!args
- (let name (sym k)
- (awhen (find [is (cadr _) name] fields)
- ; added sho to fix bug
- (let (typ id val sho mod) it
- (when (and mod v)
- (let newval (readvar typ v fail*)
- (unless (is newval fail*)
- (f name newval))))))))
- (done))))
+ (taform lasts
+ (if (all [no (_ 4)] fields)
+ (fn (req))
+ (fn (req)
+ (when-umatch user req
+ (each (k v) req!args
+ (let name (sym k)
+ (awhen (find [is (cadr _) name] fields)
+ ; added sho to fix bug
+ (let (typ id val sho mod) it
+ (when (and mod v)
+ (let newval (readvar typ v fail*)
+ (unless (is newval fail*)
+ (f name newval))))))))
+ (done))))
(tab
(showvars fields))
(unless (all [no (_ 4)] fields) ; no modifiable fields
@@ -415,7 +429,7 @@
; http://daringfireball.net/projects/markdown/syntax
(def md-from-form (str (o nolinks))
- (markdown (trim (rem #\return (esc<>& str)) 'end) 60 nolinks))
+ (markdown (trim (rem #\return (esc-tags str)) 'end) 60 nolinks))
(def markdown (s (o maxurl) (o nolinks))
(let ital nil
@@ -490,7 +504,7 @@
; Note that > immediately after a url (http://foo.com>) will cause
; an odd result, because the > gets escaped to something beginning
; with &, which is treated as part of the url. Perhaps the answer
-; is just to esc<>& after markdown instead of before.
+; is just to esc-tags after markdown instead of before.
; Treats a delimiter as part of a url if it is (a) an open delimiter
; not followed by whitespace or eos, or (b) a close delimiter
@@ -573,9 +587,9 @@
(if (in cleanlabel "am" "midnight")
0
12)
- (is cleanlabel "pm")
- (+ h 12)
- h)
+ (is cleanlabel "am")
+ h
+ (+ h 12))
60)
m))))
View
@@ -204,7 +204,8 @@
(def empty (seq)
(or (no seq)
- (and (no (acons seq)) (is (len seq) 0))))
+ (and (or (is (type seq) 'string) (is (type seq) 'table))
+ (is (len seq) 0))))
(def reclist (f xs)
(and xs (or (f xs) (reclist f (cdr xs)))))
@@ -1233,7 +1234,7 @@
(def inst (tem . args)
(let x (table)
- (each (k v) (templates* tem)
+ (each (k v) (if (acons tem) tem (templates* tem))
(unless (no v) (= (x k) (v))))
(each (k v) (pair args)
(= (x k) v))
@@ -1248,7 +1249,7 @@
; Note: discards fields not defined by the template.
(def templatize (tem raw)
- (with (x (inst tem) fields (templates* tem))
+ (with (x (inst tem) fields (if (acons tem) tem (templates* tem)))
(each (k v) raw
(when (assoc k fields)
(= (x k) v)))
View
@@ -1,8 +1,8 @@
To run News:
-tar xvf arc3.tar
+tar xvf arc3.1.tar
-cd arc3
+cd arc3.1
mkdir arc
View
@@ -61,6 +61,9 @@
(def opsel (key val)
`(if ,val (pr " selected")))
+(def opcheck (key val)
+ `(if ,val (pr " checked")))
+
(def opesc (key val)
`(awhen ,val
(pr ,(string " " key "=\""))
@@ -106,8 +109,9 @@
(attribute input size opnum)
(attribute input type opsym)
(attribute input value opesc)
-(attribute option selected opsel)
+(attribute input checked opcheck)
(attribute select name opstring)
+(attribute option selected opsel)
(attribute table bgcolor opcolor)
(attribute table border opnum)
(attribute table cellpadding opnum)
@@ -343,7 +347,7 @@
#\& "&#38;"
c)))))
-(def esc<>& (str)
+(def esc-tags (str)
(tostring
(each c str
(pr (case c #\< "&#60;"
Oops, something went wrong.

0 comments on commit f01d3f9

Please sign in to comment.