Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse files

- remove thread parameter in java code all over the place

 - optimise compose/complement in fn position just like arc does
 - new andf ssyntax
 - new flushout builtin from arc3
 - coerce int->num fix
 - no longer use rainbow/init.arc; call* defined in Console
 - updated spiral.arc for arc3 changes
  • Loading branch information...
commit 671231f890416e9940857c5f5fa739a89c606972 1 parent 3bc7e37
conan authored
Showing with 1,185 additions and 1,106 deletions.
  1. +1 −1  LICENSE.txt
  2. +156 −67 src/arc/ac.scm
  3. +1 −5 src/arc/app.arc
  4. +162 −114 src/arc/arc.arc
  5. +11 −2 src/arc/how-to-run-news
  6. +10 −2 src/arc/html.arc
  7. +6 −96 src/arc/lib/parser.arc
  8. +6 −6 src/arc/lib/source.arc
  9. +3 −3 src/arc/lib/tests/core-errors-continuations-test.arc
  10. +79 −1 src/arc/lib/tests/core-evaluation-test.arc
  11. +11 −13 src/arc/lib/tests/core-special-forms-test.arc
  12. +6 −2 src/arc/lib/tests/core-typing-test.arc
  13. +9 −9 src/arc/lib/tests/parser-test.arc
  14. +3 −0  src/arc/lib/unit-test.arc
  15. +234 −343 src/arc/news.arc
  16. +7 −7 src/arc/pprint.arc
  17. +0 −6 src/arc/rainbow/init.arc
  18. +40 −27 src/arc/rainbow/spiral.arc
  19. +5 −36 src/arc/rainbow/tests/chained-ssexpand-test.arc
  20. +66 −61 src/arc/srv.arc
  21. 0  {arc/public_html → src/arc/static}/spiral.css
  22. 0  {arc/public_html → src/arc/static}/spiral.js
  23. +0 −1  src/cc/ArcParser.jj
  24. +2 −2 src/java/rainbow/Console.java
  25. +1 −2  src/java/rainbow/Function.java
  26. +9 −2 src/java/rainbow/Nil.java
  27. +3 −4 src/java/rainbow/functions/Builtin.java
  28. +8 −9 src/java/rainbow/functions/Errors.java
  29. +47 −12 src/java/rainbow/functions/Evaluation.java
  30. +27 −22 src/java/rainbow/functions/IO.java
  31. +7 −8 src/java/rainbow/functions/InterpretedFunction.java
  32. +1 −2  src/java/rainbow/functions/Java.java
  33. +3 −4 src/java/rainbow/functions/Macex.java
  34. +4 −4 src/java/rainbow/functions/Predicates.java
  35. +4 −5 src/java/rainbow/functions/SystemFunctions.java
  36. +2 −3 src/java/rainbow/functions/Tables.java
  37. +11 −12 src/java/rainbow/functions/Threads.java
  38. +11 −4 src/java/rainbow/functions/Typing.java
  39. +11 −4 src/java/rainbow/types/ArcObject.java
  40. +3 −4 src/java/rainbow/types/ArcString.java
  41. +6 −7 src/java/rainbow/types/Hash.java
  42. +1 −1  src/java/rainbow/types/JavaProxy.java
  43. +4 −0 src/java/rainbow/types/Output.java
  44. +8 −5 src/java/rainbow/types/Pair.java
  45. +1 −2  src/java/rainbow/types/Symbol.java
  46. +3 −5 src/java/rainbow/types/Tagged.java
  47. +5 −0 src/java/rainbow/vm/Continuation.java
  48. +3 −5 src/java/rainbow/vm/compiler/AssignmentBuilder.java
  49. +30 −17 src/java/rainbow/vm/compiler/Compiler.java
  50. +4 −5 src/java/rainbow/vm/compiler/FunctionBodyBuilder.java
  51. +3 −5 src/java/rainbow/vm/compiler/FunctionParameterListBuilder.java
  52. +7 −9 src/java/rainbow/vm/compiler/IfBuilder.java
  53. +3 −5 src/java/rainbow/vm/compiler/MacExpander.java
  54. +4 −5 src/java/rainbow/vm/compiler/PairExpander.java
  55. +1 −1  src/java/rainbow/vm/compiler/QuasiQuoteBuilder.java
  56. +15 −15 src/java/rainbow/vm/compiler/QuasiQuoteCompiler.java
  57. +1 −1  src/java/rainbow/vm/compiler/Rebuilder.java
  58. +3 −4 src/java/rainbow/vm/continuations/AssignmentContinuation.java
  59. +5 −5 src/java/rainbow/vm/continuations/Atomic.java
  60. +2 −3 src/java/rainbow/vm/continuations/CallWStdinContinuation.java
  61. +2 −3 src/java/rainbow/vm/continuations/CallWStdoutContinuation.java
  62. +2 −3 src/java/rainbow/vm/continuations/ConditionalContinuation.java
  63. +23 −0 src/java/rainbow/vm/continuations/ContinuationSupport.java
  64. +3 −4 src/java/rainbow/vm/continuations/ErrorHandler.java
  65. +1 −1  src/java/rainbow/vm/continuations/ErrorPassingContinuation.java
  66. +5 −6 src/java/rainbow/vm/continuations/EvaluatorContinuation.java
  67. +7 −8 src/java/rainbow/vm/continuations/FunctionEvaluator.java
  68. +4 −5 src/java/rainbow/vm/continuations/InvocationContinuation.java
  69. +5 −5 src/java/rainbow/vm/continuations/NamespaceBuilder.java
  70. +4 −5 src/java/rainbow/vm/continuations/Protector.java
  71. +10 −10 src/java/rainbow/vm/continuations/QuasiQuoteContinuation.java
  72. +1 −1  src/java/rainbow/vm/continuations/ResultPassingContinuation.java
  73. +3 −3 src/java/rainbow/vm/continuations/TableMapper.java
  74. +1 −1  src/java/rainbow/vm/continuations/UnquoteSplicer.java
  75. +2 −3 src/java/rainbow/vm/interpreter/Assignment.java
  76. +1 −2  src/java/rainbow/vm/interpreter/BoundSymbol.java
  77. +1 −1  src/java/rainbow/vm/interpreter/Else.java
  78. +2 −3 src/java/rainbow/vm/interpreter/IfClause.java
  79. +2 −2 src/java/rainbow/vm/interpreter/IfThen.java
  80. +2 −3 src/java/rainbow/vm/interpreter/Invocation.java
  81. +2 −2 src/java/rainbow/vm/interpreter/LastIfThen.java
  82. +6 −3 src/java/rainbow/vm/interpreter/QuasiQuotation.java
  83. +1 −2  src/java/rainbow/vm/interpreter/Quotation.java
  84. +4 −5 src/java/rainbow/vm/interpreter/SingleAssignment.java
  85. +1 −2  src/java/rainbow/vm/interpreter/invocation/FirstArg.java
  86. +3 −5 src/java/rainbow/vm/interpreter/invocation/FunctionInvocation.java
  87. +1 −2  src/java/rainbow/vm/interpreter/invocation/IntermediateArg.java
  88. +1 −2  src/java/rainbow/vm/interpreter/invocation/InvocationComponent.java
  89. +2 −3 src/java/rainbow/vm/interpreter/invocation/LastArg.java
  90. +2 −3 src/java/rainbow/vm/interpreter/invocation/NoArgs.java
  91. +2 −3 src/java/rainbow/vm/interpreter/invocation/SingleArg.java
2  LICENSE.txt
View
@@ -1,4 +1,4 @@
-This software is copyright (c) Conan Dalton 2008. All Rights Reserved. Permission to use it is granted under the Perl Foundations's Artistic License 2.0.
+This software is copyright (c) Conan Dalton 2008. Permission to use it is granted under the Perl Foundations's Artistic License 2.0.
This software includes software that is copyright (c) Paul Graham and Robert Morris, distributed under the Perl Foundations's Artistic License 2.0.
223 src/arc/ac.scm
View
@@ -16,7 +16,7 @@
; need in order to decide whether set should create a global.
(define (ac s env)
- (cond ((string? s) (string-copy s)) ; to avoid immutable strings
+ (cond ((string? s) (ac-string s env))
((literal? s) s)
((eqv? s 'nil) (list 'quote 'nil))
((ssyntax? s) (ac (expand-ssyntax s) env))
@@ -27,13 +27,30 @@
((eq? (xcar s) 'if) (ac-if (cdr s) env))
((eq? (xcar s) 'fn) (ac-fn (cadr s) (cddr s) env))
((eq? (xcar s) 'assign) (ac-set (cdr s) env))
- ; the next two clauses could be removed without changing semantics
+ ; the next three clauses could be removed without changing semantics
+ ; ... except that they work for macros (so prob should do this for
+ ; every elt of s, not just the car)
((eq? (xcar (xcar s)) 'compose) (ac (decompose (cdar s) (cdr s)) env))
((eq? (xcar (xcar s)) 'complement)
(ac (list 'no (cons (cadar s) (cdr s))) env))
+ ((eq? (xcar (xcar s)) 'andf) (ac-andf s env))
((pair? s) (ac-call (car s) (cdr s) env))
(#t (err "Bad object in expression" s))))
+(define atstrings #f)
+
+(define (ac-string s env)
+ (if atstrings
+ (if (atpos s 0)
+ (ac (cons 'string (map (lambda (x)
+ (if (string? x)
+ (unescape-ats x)
+ x))
+ (codestring s)))
+ env)
+ (unescape-ats s))
+ (string-copy s))) ; avoid immutable strings
+
(define (literal? x)
(or (boolean? x)
(char? x)
@@ -45,12 +62,17 @@
(and (symbol? x)
(not (or (eqv? x '+) (eqv? x '++) (eqv? x '_)))
(let ((name (symbol->string x)))
- (has-ssyntax-char? name (- (string-length name) 1)))))
+; (has-ssyntax-char? name (- (string-length name) 1)))))
+
+ (or (eqv? (string-ref name 0) #\~)
+ (has-ssyntax-char? name (- (string-length name) 1))))))
(define (has-ssyntax-char? string i)
(and (>= i 0)
(or (let ((c (string-ref string i)))
- (or (eqv? c #\:) (eqv? c #\~) ;(eqv? c #\_)
+ (or (eqv? c #\:) ;(eqv? c #\~)
+ (eqv? c #\+)
+ ;(eqv? c #\_)
(eqv? c #\.) (eqv? c #\!)))
(has-ssyntax-char? string (- i 1)))))
@@ -64,8 +86,16 @@
; 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
+; (complement (andf foo bar)).
+
+(define (symstart? char sym) (eqv? char (car (symbol->chars sym))))
+
(define (expand-ssyntax sym)
- ((cond ((or (insym? #\: sym) (insym? #\~ sym)) expand-compose)
+ ;((cond ((or (insym? #\: sym) (insym? #\~ sym)) expand-compose)
+ ((cond ((or (insym? #\: sym) (symstart? #\~ sym)) expand-compose)
+ ((insym? #\+ sym) expand-and)
; ((insym? #\_ sym) expand-curry)
((or (insym? #\. sym) (insym? #\! sym)) expand-sexpr)
(#t (error "Unknown ssyntax" sym)))
@@ -87,6 +117,17 @@
(car elts)
(cons 'compose elts))))
+(define (expand-and sym)
+ (let ((elts (map chars->value
+ (tokens (lambda (c) (eqv? c #\+))
+ (symbol->chars sym)
+ '()
+ '()
+ #f))))
+ (if (null? (cdr elts))
+ (car elts)
+ (cons 'andf elts))))
+
; How to include quoted arguments? Can't treat all as quoted, because
; never want to quote fn given as first. Do we want to allow quote chars
; within symbols? Could be ugly.
@@ -175,15 +216,6 @@
acc
keepsep?))))
-; Purely an optimization. Could in principle do it with a preprocessor
-; instead of adding a line to ac, but only want to do it for evaluated
-; subtrees, and much easier to figure those out in ac.
-
-(define (decompose fns args)
- (cond ((null? fns) `((fn vals (car vals)) ,@args))
- ((null? (cdr fns)) (cons (car fns) args))
- (#t (list (car fns) (decompose (cdr fns) args)))))
-
(define (ac-global-name s)
(string->symbol (string-append "_" (symbol->string s))))
@@ -513,6 +545,21 @@
((or (eq? x #f) (eq? x '())) 'nil)
(#t x)))
+; The next two are optimizations, except work for macros.
+
+(define (decompose fns args)
+ (cond ((null? fns) `((fn vals (car vals)) ,@args))
+ ((null? (cdr fns)) (cons (car fns) args))
+ (#t (list (car fns) (decompose (cdr fns) args)))))
+
+(define (ac-andf s env)
+ (ac (let ((gs (map (lambda (x) (ar-gensym)) (cdr s))))
+ `((fn ,gs
+ (and ,@(map (lambda (f) `(,f ,@gs))
+ (cdar s))))
+ ,@(cdr s)))
+ env))
+
(define err error)
; run-time primitive procedures
@@ -650,6 +697,10 @@
((null? (cdr args)) (ar-nil-terminate (car args)))
(#t (cons (car args) (ar-apply-args (cdr args))))))
+
+
+
+
(xdef cons cons)
(xdef car (lambda (x)
@@ -833,30 +884,24 @@
(lambda (port thunk)
(parameterize ((current-input-port port)) (thunk))))
-; (readc stream)
-; nil stream means stdout
-; returns nil on eof
-
-(xdef readc (lambda (str)
- (let ((p (if (ar-false? str)
- (current-input-port)
- str)))
- (let ((c (read-char p)))
- (if (eof-object? c) 'nil c)))))
-
-(xdef readb (lambda (str)
- (let ((p (if (ar-false? str)
- (current-input-port)
- str)))
- (let ((c (read-byte p)))
- (if (eof-object? c) 'nil c)))))
-
-(xdef peekc (lambda (str)
- (let ((p (if (ar-false? str)
- (current-input-port)
- str)))
- (let ((c (peek-char p)))
- (if (eof-object? c) 'nil c)))))
+(xdef readc (lambda str
+ (let ((c (read-char (if (pair? str)
+ (car str)
+ (current-input-port)))))
+ (if (eof-object? c) 'nil c))))
+
+
+(xdef readb (lambda str
+ (let ((c (read-byte (if (pair? str)
+ (car str)
+ (current-input-port)))))
+ (if (eof-object? c) 'nil c))))
+
+(xdef peekc (lambda str
+ (let ((c (peek-char (if (pair? str)
+ (car str)
+ (current-input-port)))))
+ (if (eof-object? c) 'nil c))))
(xdef writec (lambda (c . args)
(write-char c
@@ -904,41 +949,41 @@
(cond
((ar-tagged? x) (err "Can't coerce annotated object"))
((eqv? type (ar-type x)) x)
-
((char? x) (case type
- ((int) (char->ascii x))
- ((string) (string x))
- ((sym) (string->symbol (string x)))
- (else (err "Can't coerce" x type))))
+ ((int) (char->ascii x))
+ ((string) (string x))
+ ((sym) (string->symbol (string x)))
+ (else (err "Can't coerce" x type))))
((integer? x) (case type
- ((char) (ascii->char x))
- ((string) (apply number->string x args))
- (else (err "Can't coerce" x type))))
+ ((num) x)
+ ((char) (ascii->char x))
+ ((string) (apply number->string x args))
+ (else (err "Can't coerce" x type))))
((number? x) (case type
- ((int) (iround x))
- ((char) (ascii->char (iround x)))
- ((string) (apply number->string x args))
- (else (err "Can't coerce" x type))))
+ ((int) (iround x))
+ ((char) (ascii->char (iround x)))
+ ((string) (apply number->string x args))
+ (else (err "Can't coerce" x type))))
((string? x) (case type
- ((sym) (string->symbol x))
- ((cons) (ac-niltree (string->list x)))
- ((num) (or (apply string->number x args)
- (err "Can't coerce" x type)))
- ((int) (let ((n (apply string->number x args)))
- (if n
- (iround n)
- (err "Can't coerce" x type))))
- (else (err "Can't coerce" x type))))
+ ((sym) (string->symbol x))
+ ((cons) (ac-niltree (string->list x)))
+ ((num) (or (apply string->number x args)
+ (err "Can't coerce" x type)))
+ ((int) (let ((n (apply string->number x args)))
+ (if n
+ (iround n)
+ (err "Can't coerce" x type))))
+ (else (err "Can't coerce" x type))))
((pair? x) (case type
- ((string) (list->string
- (ar-nil-terminate x)))
- (else (err "Can't coerce" x type))))
+ ((string) (list->string
+ (ar-nil-terminate x)))
+ (else (err "Can't coerce" x type))))
((eqv? x 'nil) (case type
- ((string) "")
- (else (err "Can't coerce" x type))))
+ ((string) "")
+ (else (err "Can't coerce" x type))))
((symbol? x) (case type
- ((string) (symbol->string x))
- (else (err "Can't coerce" x type))))
+ ((string) (symbol->string x))
+ (else (err "Can't coerce" x type))))
(#t x))))
(xdef open-socket (lambda (num) (tcp-listen num 50 #t)))
@@ -964,6 +1009,7 @@
(xdef new-thread thread)
(xdef kill-thread kill-thread)
(xdef break-thread break-thread)
+(xdef current-thread current-thread)
(define (wrapnil f) (lambda args (apply f args) 'nil))
@@ -999,7 +1045,10 @@
; PLT scheme provides only eq? and equal? hash tables,
; we need the latter for strings.
-(xdef table (lambda () (make-hash-table 'equal)))
+(xdef table (lambda args
+ (let ((h (make-hash-table 'equal)))
+ (if (pair? args) ((car args) h))
+ h)))
;(xdef table (lambda args
; (fill-table (make-hash-table 'equal)
@@ -1315,6 +1364,8 @@
(xdef declare (lambda (key val)
(case key
+ ((atstrings)
+ (set! atstrings (not (eq? val 'nil))))
((direct-calls)
(set! direct-calls (not (eq? val 'nil))))
((explicit-flush)
@@ -1339,5 +1390,43 @@
(xdef tan tan)
(xdef log log)
+(define (codestring s)
+ (let ((i (atpos s 0)))
+ (if i
+ (cons (substring s 0 i)
+ (let* ((rest (substring s (+ i 1)))
+ (in (open-input-string rest))
+ (expr (read in))
+ (i2 (let-values (((x y z) (port-next-location in))) z)))
+ (close-input-port in)
+ (cons expr (codestring (substring rest (- i2 1))))))
+ (list s))))
+
+; First unescaped @ in s, if any. Escape by doubling.
+
+(define (atpos s i)
+ (cond ((eqv? i (string-length s))
+ #f)
+ ((eqv? (string-ref s i) #\@)
+ (if (and (< (+ i 1) (string-length s))
+ (not (eqv? (string-ref s (+ i 1)) #\@)))
+ i
+ (atpos s (+ i 2))))
+ (#t
+ (atpos s (+ i 1)))))
+
+(define (unescape-ats s)
+ (list->string (letrec ((unesc (lambda (cs)
+ (cond
+ ((null? cs)
+ '())
+ ((and (eqv? (car cs) #\@)
+ (not (null? (cdr cs)))
+ (eqv? (cadr cs) #\@))
+ (unesc (cdr cs)))
+ (#t
+ (cons (car cs) (unesc (cdr cs))))))))
+ (unesc (string->list s)))))
+
)
6 src/arc/app.arc
View
@@ -228,7 +228,7 @@
(def username-taken (user)
(when (empty dc-usernames*)
- (ontable k v hpasswords*
+ (each (k v) hpasswords*
(set (dc-usernames* (downcase k)))))
(dc-usernames* (downcase user)))
@@ -549,10 +549,6 @@
(awhen (findsubseq "</code></pre>" s (+ i 12))
(pr (cut s (+ i 11) it))
(= i (+ it 12)))
- (litmatch "<pre><code>" s i)
- (awhen (findsubseq "</code></pre>" s (+ i 12))
- (pr (cut s (+ i 11) it))
- (= i (+ it 12)))
(writec (s i))))))
276 src/arc/arc.arc
View
@@ -13,12 +13,12 @@
; warn when shadow a global name
; some simple regexp/parsing plan
-; compromises in this implementation:
+; compromises in this implementation:
; no objs in code
; (mac testlit args (listtab args)) breaks when called
; separate string type
; (= (cdr (cdr str)) "foo") couldn't work because no way to get str tail
-; not sure this is a mistake; strings may be subtly different from
+; not sure this is a mistake; strings may be subtly different from
; lists of chars
@@ -54,8 +54,8 @@
; (def list args args)
(def copylist (xs)
- (if (no xs)
- nil
+ (if (no xs)
+ nil
(cons (car xs) (copylist (cdr xs)))))
(def list args (copylist args))
@@ -65,7 +65,7 @@
; Maybe later make this internal. Useful to let xs be a fn?
(def map1 (f xs)
- (if (no xs)
+ (if (no xs)
nil
(cons (f (car xs)) (map1 f (cdr xs)))))
@@ -107,9 +107,9 @@
`(with (,var ,val) ,@body))
(mac withs (parms . body)
- (if (no parms)
+ (if (no parms)
`(do ,@body)
- `(let ,(car parms) ,(cadr parms)
+ `(let ,(car parms) ,(cadr parms)
(withs ,(cddr parms) ,@body))))
; Rtm prefers to overload + to do this
@@ -117,8 +117,8 @@
(def join args
(if (no args)
nil
- (let a (car args)
- (if (no a)
+ (let a (car args)
+ (if (no a)
(apply join (cdr args))
(cons (car a) (apply join (cdr a) (cdr args)))))))
@@ -134,7 +134,7 @@
; Ac expands x:y:z into (compose x y z), ~x into (complement x)
-; Only used when the call to compose doesn't occur in functional position.
+; Only used when the call to compose doesn't occur in functional position.
; Composes in functional position are transformed away by ac.
(mac compose args
@@ -152,7 +152,7 @@
(let g (uniq)
`(fn ,g (no (apply ,f ,g)))))
-(def rev (xs)
+(def rev (xs)
((afn (xs acc)
(if (no xs)
acc
@@ -185,9 +185,9 @@
(def iso (x y)
(or (is x y)
- (and (acons x)
- (acons y)
- (iso (car x) (car y))
+ (and (acons x)
+ (acons y)
+ (iso (car x) (car y))
(iso (cdr x) (cdr y)))))
(mac when (test . body)
@@ -202,20 +202,19 @@
(when ,gp ,@body (,gf ,test)))
,test)))
-(def empty (seq)
- (or (no seq)
+(def empty (seq)
+ (or (no seq)
(and (no (acons seq)) (is (len seq) 0))))
(def reclist (f xs)
(and xs (or (f xs) (reclist f (cdr xs)))))
(def recstring (test s (o start 0))
- (let n (len s)
- ((afn (i)
- (and (< i (len s))
- (or (test i)
- (self (+ i 1)))))
- start)))
+ ((afn (i)
+ (and (< i (len s))
+ (or (test i)
+ (self (+ i 1)))))
+ start))
(def testify (x)
(if (isa x 'fn) x [is _ x]))
@@ -226,9 +225,9 @@
(reclist f:car seq)
(recstring f:seq seq))))
-(def all (test seq)
+(def all (test seq)
(~some (complement (testify test)) seq))
-
+
(def mem (test seq)
(let f (testify test)
(reclist [if (f:car _) _] seq)))
@@ -255,7 +254,7 @@
(def map (f . seqs)
- (if (some [isa _ 'string] seqs)
+ (if (some [isa _ 'string] seqs)
(withs (n (apply min (map len seqs))
new (newstring n))
((afn (i)
@@ -264,10 +263,10 @@
(do (sref new (apply f (map [_ i] seqs)) i)
(self (+ i 1)))))
0))
- (no (cdr seqs))
+ (no (cdr seqs))
(map1 f (car seqs))
((afn (seqs)
- (if (some no seqs)
+ (if (some no seqs)
nil
(cons (apply f (map1 car seqs))
(self (map1 cdr seqs)))))
@@ -299,7 +298,7 @@
(mac defs args
`(do ,@(map [cons 'def _] (tuples args 3))))
-(def caris (x val)
+(def caris (x val)
(and (acons x) (is (car x) val)))
(def warn (msg . args)
@@ -312,7 +311,7 @@
(mac atlet args
`(atomic (let ,@args)))
-
+
(mac atwith args
`(atomic (with ,@args)))
@@ -337,7 +336,7 @@
(mac defset (name parms . body)
(w/uniq gexpr
- `(sref setter
+ `(sref setter
(fn (,gexpr)
(let ,parms (cdr ,gexpr)
,@body))
@@ -374,8 +373,8 @@
`(fn (val) (scdr (cdr ,g) val)))))
; Note: if expr0 macroexpands into any expression whose car doesn't
-; have a setter, setforms assumes it's a data structure in functional
-; position. Such bugs will be seen only when the code is executed, when
+; have a setter, setforms assumes it's a data structure in functional
+; position. Such bugs will be seen only when the code is executed, when
; sref complains it can't set a reference to a function.
(def setforms (expr0)
@@ -441,7 +440,7 @@
(mac loop (start test update . body)
(w/uniq (gfn gparm)
`(do ,start
- ((rfn ,gfn (,gparm)
+ ((rfn ,gfn (,gparm)
(if ,gparm
(do ,@body ,update (,gfn ,test))))
,test))))
@@ -452,31 +451,37 @@
(loop (assign ,v ,gi) (< ,v ,gm) (assign ,v (+ ,v 1))
,@body))))
+(mac down (v init min . body)
+ (w/uniq (gi gm)
+ `(with (,v nil ,gi ,init ,gm (- ,min 1))
+ (loop (assign ,v ,gi) (> ,v ,gm) (assign ,v (- ,v 1))
+ ,@body))))
+
(mac repeat (n . body)
`(for ,(uniq) 1 ,n ,@body))
; could bind index instead of gensym
(mac each (var expr . body)
- (w/uniq (gseq g)
+ (w/uniq (gseq gf gv)
`(let ,gseq ,expr
(if (alist ,gseq)
- ((afn (,g)
- (when (acons ,g)
- (let ,var (car ,g) ,@body)
- (self (cdr ,g))))
+ ((rfn ,gf (,gv)
+ (when (acons ,gv)
+ (let ,var (car ,gv) ,@body)
+ (,gf (cdr ,gv))))
,gseq)
(isa ,gseq 'table)
- (maptable (fn (,g ,var) ,@body)
+ (maptable (fn ,var ,@body)
,gseq)
- (for ,g 0 (- (len ,gseq) 1)
- (let ,var (,gseq ,g) ,@body))))))
+ (for ,gv 0 (- (len ,gseq) 1)
+ (let ,var (,gseq ,gv) ,@body))))))
; (nthcdr x y) = (cut y x).
(def cut (seq start (o end))
(let end (if (no end) (len seq)
- (< end 0) (+ (len seq) end)
+ (< end 0) (+ (len seq) end)
end)
(if (isa seq 'string)
(let s2 (newstring (- end start))
@@ -484,10 +489,7 @@
(= (s2 i) (seq (+ start i))))
s2)
(firstn (- end start) (nthcdr start seq)))))
-
-(mac ontable (k v h . body)
- `(maptable (fn (,k ,v) ,@body) ,h))
-
+
(mac whilet (var test . body)
(w/uniq (gf gp)
`((rfn ,gf (,gp)
@@ -510,10 +512,10 @@
seq)
(coerce (rem test (coerce seq 'cons)) 'string))))
-(def keep (test seq)
+(def keep (test seq)
(rem (complement (testify test)) seq))
-;(def trues (f seq)
+;(def trues (f seq)
; (rem nil (map f seq)))
(def trues (f xs)
@@ -534,7 +536,7 @@
(mac caselet (var expr . args)
(let ex (afn (args)
- (if (no (cdr args))
+ (if (no (cdr args))
(car args)
`(if (is ,var ',(car args))
,(cadr args)
@@ -575,7 +577,7 @@
(w/uniq g
(let (binds val setter) (setforms place)
`(atwiths ,(+ binds (list g val))
- (do1 (car ,g)
+ (do1 (car ,g)
(,setter (cdr ,g)))))))
(def adjoin (x xs (o test iso))
@@ -595,6 +597,14 @@
`(atwiths ,(+ (list g test) binds)
(,setter (rem ,g ,val))))))
+(mac togglemem (x place . args)
+ (w/uniq gx
+ (let (binds val setter) (setforms place)
+ `(atwiths ,(+ (list gx x) binds)
+ (,setter (if (mem ,gx ,val)
+ (rem ,gx ,val)
+ (adjoin ,gx ,val ,@args)))))))
+
(mac ++ (place (o i 1))
(if (isa place 'sym)
`(= ,place (+ ,place ,i))
@@ -611,12 +621,12 @@
`(atwiths ,(+ binds (list gi i))
(,setter (- ,val ,gi)))))))
-; E.g. (inc x) equiv to (zap + x 1)
+; E.g. (++ x) equiv to (zap + x 1)
(mac zap (op place . args)
(with (gop (uniq)
gargs (map [uniq] args)
- mix (afn seqs
+ mix (afn seqs
(if (some no seqs)
nil
(+ (map car seqs)
@@ -628,12 +638,16 @@
; Can't simply mod pr to print strings represented as lists of chars,
; because empty string will get printed as nil. Would need to rep strings
; as lists of chars annotated with 'string, and modify car and cdr to get
-; the rep of these. That would also require hacking the reader.
+; the rep of these. That would also require hacking the reader.
(def pr args
(map1 disp args)
(car args))
+(def prt args
+ (map1 [if _ (disp _)] args)
+ (car args))
+
(def prn args
(do1 (apply pr args)
(writec #\newline)))
@@ -666,7 +680,7 @@
(mac aand args
(if (no args)
- 't
+ 't
(no (cdr args))
(car args)
`(let it ,(car args) (and it (aand ,@(cdr args))))))
@@ -697,7 +711,7 @@
`(withs (,var nil ,gf (testify ,endval))
(while (no (,gf (= ,var ,expr)))
,@body))))
-
+
;(def macex (e)
; (if (atom e)
; e
@@ -711,7 +725,7 @@
(def string args
(apply + "" (map [coerce _ 'string] args)))
-(def flat (x)
+(def flat x
((afn (x acc)
(if (no x) acc
(atom x) (cons x acc)
@@ -727,12 +741,12 @@
(let f (testify test)
(if (alist seq)
((afn (seq n)
- (if (no seq)
+ (if (no seq)
nil
- (f (car seq))
+ (f (car seq))
n
(self (cdr seq) (+ n 1))))
- (nthcdr start seq)
+ (nthcdr start seq)
start)
(recstring [if (f (seq _)) _] seq start))))
@@ -743,7 +757,7 @@
(mac after (x . ys)
`(protect (fn () ,x) (fn () ,@ys)))
-(let expander
+(let expander
(fn (f var name body)
`(let ,var (,f ,name)
(after (do ,@body) (close ,var))))
@@ -809,6 +823,13 @@
(cons x (self i)))))
(if (isa src 'string) (instring src) src)))
+(def allchars (str)
+ (tostring (whiler c (readc str nil) no
+ (writec c))))
+
+(def filechars (name)
+ (w/infile s name (allchars s)))
+
(def writefile (val file)
(let tmpfile (+ file ".tmp")
(w/outfile o tmpfile (write val o))
@@ -821,13 +842,13 @@
(mac rand-choice exprs
`(case (rand ,(len exprs))
- ,@(let key -1
+ ,@(let key -1
(mappend [list (++ key) _]
exprs))))
(mac n-of (n expr)
(w/uniq ga
- `(let ,ga nil
+ `(let ,ga nil
(repeat ,n (push ,expr ,ga))
(rev ,ga))))
@@ -863,7 +884,7 @@
(each elt (cdr seq)
(if (f elt wins) (= wins elt)))
wins)))
-
+
(def max args (best > args))
(def min args (best < args))
@@ -871,7 +892,7 @@
; (w/uniq (a b)
; `(with (,a ,x ,b ,y) (if (> ,a ,b) ,a ,b))))
-(def most (f seq)
+(def most (f seq)
(unless (no seq)
(withs (wins (car seq) topscore (f wins))
(each elt (cdr seq)
@@ -880,13 +901,13 @@
wins)))
; Insert so that list remains sorted. Don't really want to expose
-; these but seem to have to because can't include a fn obj in a
+; these but seem to have to because can't include a fn obj in a
; macroexpansion.
-
+
(def insert-sorted (test elt seq)
(if (no seq)
- (list elt)
- (test elt (car seq))
+ (list elt)
+ (test elt (car seq))
(cons elt seq)
(cons (car seq) (insert-sorted test elt (cdr seq)))))
@@ -894,18 +915,18 @@
`(zap [insert-sorted ,test ,elt _] ,seq))
(def reinsert-sorted (test elt seq)
- (if (no seq)
- (list elt)
+ (if (no seq)
+ (list elt)
(is elt (car seq))
(reinsert-sorted test elt (cdr seq))
- (test elt (car seq))
+ (test elt (car seq))
(cons elt (rem elt seq))
(cons (car seq) (reinsert-sorted test elt (cdr seq)))))
(mac insortnew (test elt seq)
`(zap [reinsert-sorted ,test ,elt _] ,seq))
-; Could make this look at the sig of f and return a fn that took the
+; Could make this look at the sig of f and return a fn that took the
; right no of args and didn't have to call apply (or list if 1 arg).
(def memo (f)
@@ -950,7 +971,7 @@
(def readline ((o str (stdin)))
(awhen (readc str)
- (tostring
+ (tostring
(writec it)
(whiler c (readc str) [in _ nil #\newline]
(writec c)))))
@@ -972,7 +993,7 @@
(def treewise (f base tree)
(if (atom tree)
(base tree)
- (f (treewise f base (car tree))
+ (f (treewise f base (car tree))
(treewise f base (cdr tree)))))
(def carif (x) (if (atom x) x (car x)))
@@ -984,8 +1005,8 @@
(pr init (car elts))
(map [pr sep _] (cdr elts))
elts))
-
-(def prs args
+
+(def prs args
(prall args "" #\space))
(def tree-subst (old new tree)
@@ -1012,11 +1033,11 @@
(each (k v) (pair data) (= (table k) v))
table)
-(def keys (h)
- (accum a (ontable k v h (a k))))
+(def keys (h)
+ (accum a (each (k v) h (a k))))
-(def vals (h)
- (accum a (ontable k v h (a v))))
+(def vals (h)
+ (accum a (each (k v) h (a v))))
; These two should really be done by coerce. Wrap coerce?
@@ -1061,7 +1082,7 @@
(= (new i) (x i)))
new)
table (let new (table)
- (ontable k v x
+ (each (k v) x
(= (new k) v))
new)
(err "Can't copy " x))
@@ -1085,7 +1106,7 @@
(def roundup (n)
(withs (base (trunc n) rem (abs (- n base)))
- (if (>= rem 1/2)
+ (if (>= rem 1/2)
((if (> n 0) + -) base 1)
base)))
@@ -1095,17 +1116,17 @@
(def avg (ns) (/ (apply + ns) (len ns)))
(def med (ns (o test >))
- ((sort > ns) (round (/ (len ns) 2))))
+ ((sort test ns) (round (/ (len ns) 2))))
; Use mergesort on assumption that mostly sorting mostly sorted lists
-; benchmark: (let td (n-of 10000 (rand 100)) (time (sort < td)) 1)
+; benchmark: (let td (n-of 10000 (rand 100)) (time (sort < td)) 1)
(def sort (test seq)
(if (alist seq)
(mergesort test (copy seq))
(coerce (mergesort test (coerce seq 'cons)) (type seq))))
-; Destructive stable merge-sort, adapted from slib and improved
+; Destructive stable merge-sort, adapted from slib and improved
; by Eli Barzilay for MzLib; re-written in Arc.
(def mergesort (less? lst)
@@ -1167,12 +1188,7 @@
(firstn n (sort f seq)))
(def split (seq pos)
- (if (< pos 1)
- (list nil seq)
- (withs (mid (nthcdr (- pos 1) seq)
- s2 (cdr mid))
- (wipe (cdr mid))
- (list seq s2))))
+ (list (cut seq 0 pos) (cut seq pos)))
(mac time (expr)
(w/uniq (t1 t2)
@@ -1195,13 +1211,13 @@
(mac deftem (tem . fields)
(withs (name (carif tem) includes (if (acons tem) (cdr tem)))
- `(= (templates* ',name)
+ `(= (templates* ',name)
(+ (mappend templates* ',(rev includes))
(list ,@(map (fn ((k v)) `(list ',k (fn () ,v)))
(pair fields)))))))
(mac addtem (name . fields)
- `(= (templates* ',name)
+ `(= (templates* ',name)
(union (fn (x y) (is (car x) (car y)))
(list ,@(map (fn ((k v)) `(list ',k (fn () ,v)))
(pair fields)))
@@ -1234,7 +1250,7 @@
(w/infile i file (temread tem i)))
(def temloadall (tem file)
- (map (fn (pairs) (templatize tem pairs))
+ (map (fn (pairs) (templatize tem pairs))
(w/infile in file (readall in))))
@@ -1266,7 +1282,7 @@
(def saferead (arg) (errsafe:read arg))
-(def safe-load-table (filename)
+(def safe-load-table (filename)
(or (errsafe:load-table filename)
(table)))
@@ -1292,7 +1308,7 @@
str
(+ (cut str 0 limit) "...")))
-(def rand-elt (seq)
+(def rand-elt (seq)
(seq (rand (len seq))))
(mac until (test . body)
@@ -1303,10 +1319,18 @@
(and xp (or (no yp) (< xp yp)))))
(def orf fns
- (fn (x) (some [_ x] fns)))
+ (fn args
+ ((afn (fs)
+ (and fs (or (apply (car fs) args) (self (cdr fs)))))
+ fns)))
(def andf fns
- (fn (x) (all [_ x] fns)))
+ (fn args
+ ((afn (fs)
+ (if (no fs) t
+ (no (cdr fs)) (apply (car fs) args)
+ (and (apply (car fs) args) (self (cdr fs)))))
+ fns)))
(def atend (i s)
(> i (- (len s) 2)))
@@ -1314,9 +1338,9 @@
(def multiple (x y)
(is 0 (mod x y)))
-(mac nor args `(no (or ,@args)))
+(mac nor args `(no (or ,@args)))
-; Consider making the default sort fn take compare's two args (when do
+; Consider making the default sort fn take compare's two args (when do
; you ever have to sort mere lists of numbers?) and rename current sort
; as prim-sort or something.
@@ -1333,7 +1357,7 @@
; (def only (f g . args) (aif (apply g args) (f it)))
-(def only (f)
+(def only (f)
(fn args (if (car args) (apply f args))))
(mac conswhen (f x y)
@@ -1371,7 +1395,7 @@
(def commonest (seq)
(with (winner nil n 0)
- (ontable k v (counts seq)
+ (each (k v) (counts seq)
(when (> v n) (= winner k n v)))
(list winner n)))
@@ -1392,7 +1416,7 @@
(with (chars nil i -1)
(w/instring s str
(whilet c (readc s)
- (case c
+ (case c
#\# (do (a (coerce (rev chars) 'string))
(wipe chars)
(a (read s)))
@@ -1403,7 +1427,7 @@
(push c chars))))
(when chars
(a (coerce (rev chars) 'string))))))
-
+
(mac prf (str . args)
`(let ,argsym (list ,@args)
(pr ,@(parse-format str))))
@@ -1415,12 +1439,15 @@
(whiler e (read f eof) eof
(eval e)))))
+(def positive (x)
+ (and (number x) (> x 0)))
+
(mac w/table (var . body)
`(let ,var (table) ,@body ,var))
(def ero args
- (w/stdout (stderr)
- (each a args
+ (w/stdout (stderr)
+ (each a args
(write a)
(writec #\space))
(writec #\newline))
@@ -1464,7 +1491,7 @@
`(with (,gn ,n ,gc 0)
(each ,var ,val
(when (multiple (++ ,gc) ,gn)
- (pr ".")
+ (pr ".")
(flushout)
)
,@body)
@@ -1472,9 +1499,9 @@
(flushout))))
(mac point (name . body)
- (w/uniq g
+ (w/uniq (g p)
`(ccc (fn (,g)
- (let ,name [,g _]
+ (let ,name (fn ((o ,p)) (,g ,p))
,@body)))))
(mac catch body
@@ -1538,7 +1565,7 @@
(def len> (x n) (> (len x) n))
-(mac thread body
+(mac thread body
`(new-thread (fn () ,@body)))
(mac trav (x . fs)
@@ -1560,7 +1587,7 @@
(mac defhook (name . rest)
`(= (hooks* ',name) (fn ,@rest)))
-
+
(mac out (expr) `(pr ,(tostring (eval expr))))
; if renamed this would be more natural for (map [_ user] pagefns*)
@@ -1584,10 +1611,31 @@
`(fromdisk ,var ,file (table) load-table save-table))
(mac todisk (var (o expr var))
- `((savers* ',var)
+ `((savers* ',var)
,(if (is var expr) var `(= ,var ,expr))))
+(mac evtil (expr test)
+ (w/uniq gv
+ `(let ,gv ,expr
+ (while (no (,test ,gv))
+ (= ,gv ,expr))
+ ,gv)))
+
+(def rand-key (h)
+ (if (empty h)
+ nil
+ (let n (rand (len h))
+ (catch
+ (each (k v) h
+ (when (is (-- n) -1)
+ (throw k)))))))
+
+(def ratio (test xs)
+ (if (empty xs)
+ 0
+ (/ (count (testify test) xs) (len xs))))
+
; any logical reason I can't say (push x (if foo y z)) ?
; eval would have to always ret 2 things, the val and where it came from
@@ -1596,12 +1644,12 @@
; idea: use constants in functional position for currying?
; (1 foo) would mean (fn args (apply foo 1 args))
-; another solution would be to declare certain symbols curryable, and
+; another solution would be to declare certain symbols curryable, and
; if > was, >_10 would mean [> _ 10]
; or just say what the hell and make _ ssyntax for currying
; idea: make >10 ssyntax for [> _ 10]
; solution to the "problem" of improper lists: allow any atom as a list
-; terminator, not just nil. means list recursion should terminate on
+; terminator, not just nil. means list recursion should terminate on
; atom rather than nil, (def empty (x) (or (atom x) (is x "")))
; table should be able to take an optional initial-value. handle in sref.
; warn about code of form (if (= )) -- probably mean is
13 src/arc/how-to-run-news
View
@@ -22,7 +22,9 @@ click on login, and create an account called myname
you should now be logged in as an admin
-(don't worry about "user break" messages when restarting News.)
+manually give at least 10 karma to your initial set of users
+
+don't worry about "user break" messages when restarting News
@@ -30,5 +32,12 @@ To customize News:
change the variables at the top of news.arc
-replace arc3/static/y18.gif with an 18x18 gif of your choice
+
+To improve performance:
+
+(= static-max-age* 7200) ; browsers can cache static files for 7200 sec
+
+(declare direct-calls t) ; you promise not to redefine fns as tables
+
+(declare explicit-flush t) ; you take responsibility for flushing output
12 src/arc/html.arc
View
@@ -177,7 +177,7 @@
(let meth (if (is opt 'style) opstring (opmeth spec opt))
(if meth
(if val
- (cons (if (literal val)
+ (cons (if (precomputable-tagopt val)
(tostring (eval (meth opt val)))
(meth opt val))
(tag-options spec rest))
@@ -186,6 +186,10 @@
(pr "<!-- ignoring " opt " for " spec "-->")
(tag-options spec rest)))))))
+(def precomputable-tagopt (val)
+ (and (literal val)
+ (no (and (is (type val) 'string) (find #\@ val)))))
+
(def br ((o n 1))
(repeat n (pr "<br>"))
(prn))
@@ -400,4 +404,8 @@
(~find [in _ #\< #\> #\" #\'] url)))
(mac fontcolor (c . body)
- `(tag (font color ,c) ,@body))
+ (w/uniq g
+ `(let ,g ,c
+ (if ,g
+ (tag (font color ,g) ,@body)
+ (do ,@body)))))
102 src/arc/lib/parser.arc
View
@@ -1,3 +1,6 @@
+; This software is copyright (c) Conan Dalton 2008. Permission to use
+; it is granted under the Perl Foundations's Artistic License 2.0.
+
(assign syntax-chars (obj
#\( 'left-paren
#\) 'right-paren
@@ -116,101 +119,8 @@
(assign state default))
(add-to-token ch)))
interpolating (fn (ch)
- (if (is ch #\() (do (assign state default)
- (enq-token 'string-fragment)
- (add-to-token #\#)
- (add-to-token #\()
- (enq-token 'interpolation-start))
- (do (add-to-token #\#)
- (if (is len.token 1) (-- token-start))
- ((assign state in-string) ch))))
- escaping (fn (ch)
- (add-to-token ch)
- (assign state in-string))
- in-character (fn (ch)
- (if (and (> (len token) 2) (char-terminator ch))
- ((enq/switch0 default) ch)
- (add-to-token ch)))
- in-comment (fn (ch)
- (if (is ch #\newline) ((enq/switch0 default) ch)
- (add-to-token ch)))
- in-atom (fn (ch)
- (if (or whitespace?.ch
- syntax-chars.ch) ((enq/switch0 default) ch)
- (add-to-token ch)))
- in-unquote (fn (ch)
- (if (is ch #\@) (enq/switch 'unquote-splicing default)
- ((enq/switch 'unquote default) ch))))
-
- (assign state default)
-
- (list
- (fn () (tokenator))
- (fn () lines)
- (fn () (assign state in-string)))))
-
-(def arc-tokeniser2 (char-stream)
- (with ((default in-string interpolating escaping in-character in-comment in-atom in-unquote) nil
- (token state token-queue) nil
- (nextc enq-token enq-token1 enq/switch0 enq/switch tokenator add-to-token) nil
- lines 1
- char-count 0
- token-start 0)
-
- (= nextc (fn ()
- (assign char-count (+ char-count 1))
- (readc char-stream))
- enq-token (fn ((o token-kind nil))
- (when token
- (fpush (list token (- token-start 1) token-kind) token-queue)
- (fwipe token)))
- enq-token1 (fn (another (o token-kind nil))
- (enq-token token-kind)
- (fpush (list another (- char-count 1) nil) token-queue))
- enq/switch0 (fn (new-state)
- (enq-token)
- (assign state new-state))
- enq/switch (fn (another-tok new-state)
- (enq-token1 another-tok)
- (assign state new-state))
- tokenator (afn ()
- (if token-queue
- (let q rev.token-queue
- (assign token-queue (rev cdr.q))
- (tokenise car.q))
- (aif (nextc)
- (do (if (is it #\newline)
- (assign lines (+ 1 lines)))
- state.it
- (self))
- token
- (do (enq-token) (self)))))
- add-to-token (fn (ch)
- (if (no token) (assign token-start char-count))
- (fpush ch token))
-
- default (fn (ch)
- (if whitespace?.ch (add-to-token ch)
- syntax-chars.ch (enq-token1 syntax-chars.ch)
- (is ch #\.) (enq-token1 'dot)
- (is ch #\") (enq/switch 'left-string-delimiter in-string)
- (is ch #\#) ((enq/switch0 in-character) ch)
- (is ch #\,) (enq/switch0 in-unquote)
- (is ch #\;) ((enq/switch0 in-comment) ch)
- ((enq/switch0 in-atom) ch)))
- in-string (fn (ch)
- (if (is ch #\\) (do (add-to-token ch)
- (assign state escaping))
- (is ch #\#) (assign state interpolating)
- (is ch #\") (do (enq-token1 'right-string-delimiter 'string-fragment)
- (assign state default))
- (add-to-token ch)))
- interpolating (fn (ch)
- (if (is ch #\() (do (assign state default)
- (enq-token 'string-fragment)
- (add-to-token #\#)
- (add-to-token #\()
- (enq-token 'interpolation-start))
+ (if (is ch #\() (do (enq-token 'string-fragment)
+ (enq/switch 'interpolation default))
(do (add-to-token #\#)
(if (is len.token 1) (-- token-start))
((assign state in-string) ch))))
@@ -294,7 +204,7 @@
(let token (token-generator)
(if (token? token 'syntax 'right-string-delimiter)
(assemble-string fragments)
- (token? token 'interpolation-start)
+ (token? token 'syntax 'interpolation)
(do (push (read-form token-generator) fragments)
(let token2 (token-generator)
(if (token? token2 'syntax 'right-paren)
12 src/arc/lib/source.arc
View
@@ -14,13 +14,13 @@
(def index-defs (files itable)
(each f files
(prn "indexing definitions from " f)
- (index-from-file f
- (find-defs f)
+ (index-from-file f
+ (find-defs f)
itable)))
(def index-from-file (file toks itable)
(each tok toks
- (zap [cons (list file (tok 3)) _]
+ (zap [cons (list file (tok 3)) _]
(itable (cadr tok)))))
(def delete-from-index (itable remfn)
@@ -33,15 +33,15 @@
(let (fd1 fd2 fd3) nil
(defs
- fd1 (tok tkz acc) (if tok
+ fd1 (tok tkz acc) (if tok
(fdcall (if (token? tok 'syntax 'left-paren) fd2 fd1)))
- fd2 (tok tkz acc) (if tok
+ fd2 (tok tkz acc) (if tok
(fdcall
(if (find cadr.tok definers) fd3
(is car.tok 'whitespace) fd2
fd1)))
fd3 (tok tkz acc) (if (and tok (~is car.tok 'whitespace))
- (do (if (is car.tok 'sym)
+ (do (if (is car.tok 'sym)
(acc tok))
(fdcall fd1))
(fdcall fd3))
6 src/arc/lib/tests/core-errors-continuations-test.arc
View
@@ -6,14 +6,14 @@
"bailout value")
("support continuation-passing style to calculate hypoteneuse"
- ( (fn ((cps* cps+ cps-sqrt cps-pyth))
+ ( (fn ((cps* cpsplus cps-sqrt cps-pyth))
(assign cps* (fn (x y k) (k (* x y))))
- (assign cps+ (fn (x y k) (k (+ x y))))
+ (assign cpsplus (fn (x y k) (k (+ x y))))
(assign cps-sqrt (fn (x k) (k (sqrt x))))
(assign cps-pyth (fn (x y k)
(cps* x x (fn (x2)
(cps* y y (fn (y2)
- (cps+ x2 y2 (fn (x2py2)
+ (cpsplus x2 y2 (fn (x2py2)
(cps-sqrt x2py2 k)))))))))
(< 6.40312423743284 (ccc (fn (cc) (cps-pyth 4 5 cc))) 6.40312423743285)) nil)
t)
80 src/arc/lib/tests/core-evaluation-test.arc
View
@@ -59,7 +59,24 @@
("recognises list-quoted"
(ssyntax 'a!b)
- t ))
+ t )
+
+ ("andf"
+ (ssyntax 'a+b)
+ t)
+
+ ("andf"
+ (ssyntax '+a+b+)
+ t)
+
+ ("andf - ignore +"
+ (ssyntax '+)
+ nil)
+
+ ("andf - ignore ++"
+ (ssyntax '++)
+ nil)
+ )
(suite "special syntax invocation (compose is implemented in Arc)"
("direct invocation"
@@ -75,3 +92,64 @@
((fn (addand)
(addand sqrt:* 5 20 1.0)) (fn (op x y z) (+ z (op x y))))
11.0 )))))
+
+(register-test '(suite "ssexpand"
+ ("expand compose"
+ (ssexpand 'x:y)
+ (compose x y))
+
+ ("expand complement"
+ (ssexpand '~p)
+ (complement p))
+
+ ("expand compose/complement"
+ (ssexpand 'p:~q:r)
+ (compose p (complement q) r) )
+
+ ("expand compose/complement"
+ (ssexpand '~p:q:r)
+ (compose (complement p) q r) )
+
+ ("expand list"
+ (ssexpand '*.a.b)
+ ((* a) b))
+
+ ("expand quoted list"
+ (ssexpand 'cons!a!b)
+ ((cons (quote a)) (quote b)) )
+
+ ("expand chained dots and bangs"
+ (ssexpand 'a.b!c.d)
+ (((a b) (quote c)) d))
+
+ ("ssexpand with initial dot"
+ (ssexpand '.a.b.c)
+ (((get a) b) c))
+
+ ("ssexpand with initial quote"
+ (ssexpand '!a.b.c)
+ (((get (quote a)) b) c))
+
+ ("andf"
+ (ssexpand 'a+b)
+ (andf a b))
+))
+
+(register-test '(suite "using special syntax"
+ ("everything at once, in functional position"
+ ((fn (x p) (tostring (pr:odd+~x.p 7) (pr:odd+~x.p 8) (pr:odd+~x.p 9))) (fn (n) (fn (p) (is (mod p n) 0))) 3)
+ "tnilnil")
+
+ ("everything at once, as argument"
+ ((fn (y p) (tostring:map pr:odd+~y.p '(7 8 9))) (fn (n) (fn (p) (is (mod p n) 0))) 3)
+ "tnilnil")
+
+ ("everything at once, as argument"
+ ((fn (y p) (tostring:map pr:~y.p '(7 8 9))) (fn (n) (fn (p) (is (mod p n) 0))) 3)
+ "ttnil")
+
+ ("everything at once, as argument"
+ ((fn (y p) (tostring:map odd+pr '(7 8 9))) (fn (n) (fn (p) (is (mod p n) 0))) 3)
+ "79")
+
+ ))
24 src/arc/lib/tests/core-special-forms-test.arc
View
@@ -45,7 +45,7 @@
`qqqfoo
qqqfoo )
- ("quais-quote quasi-quote"
+ ("quasi-quote quasi-quote"
``double-qq
`double-qq )
@@ -130,7 +130,7 @@
( (fn args (apply + args)) 17 13 14 16)
60)
- ("a simple function with a body parameter"
+ ("a simple function with a rest parameter"
( (fn (a b . c) (* (- a b) (apply + c))) 20 15 19 20 21)
300)
@@ -146,7 +146,7 @@
99)
("nested variables are lexically scoped - really"
- ( (fn ()
+ ((fn ()
((fn (a)
((fn (b)
((fn (c)
@@ -177,19 +177,17 @@
65)
("optional args evaluated at invocation time, but in lexical scope of fn definition"
- ((fn ()
- (assign fopt (fn (x (o y z)) (cons x y)))
- (assign z 'goo)
- ( (fn (z) (fopt 2)) 'zoo)
- ))
+ ((fn (z)
+ (assign test-opt-arg (fn (x (o y z)) (cons x y)))
+ ( (fn (z) (test-opt-arg 2)) 'zoo)
+ ) 'goo)
(2 . goo))
("optional arg may be invocation"
- ((fn ()
- (assign fopt (fn (x (o y (+ z z))) (cons x y)))
- (assign z 25)
- ( (fn (z) (fopt 2)) 101)
- ))
+ ((fn (z)
+ (assign test-opt-arg (fn (x (o y (+ z z))) (cons x y)))
+ ( (fn (z) (test-opt-arg 2)) 101)
+ ) 25)
(2 . 50))
("o is not always an optional arg"
8 src/arc/lib/tests/core-typing-test.arc
View
@@ -231,8 +231,8 @@
"")
("list to string"
- (coerce '(#\z #\o #\o #\, #\?) 'string)
- "zoo,?" )
+ (coerce '(#\z #\o #\o #\, #\space #\n #\o #\?) 'string)
+ "zoo, no?" )
("list to string"
(coerce '(#\a #\b #\c #\@ #\e #\x #\a #\m #\p #\l #\e #\. #\c #\o #\m) 'string)
@@ -256,6 +256,10 @@
(coerce 66 'string)
"66")
+ ("int to num"
+ (coerce 0 'num)
+ 0)
+
("int to char"
(coerce 67 'char)
#\C)
18 src/arc/lib/tests/parser-test.arc
View
@@ -15,23 +15,23 @@
("parse a number: is num" (type:parse "99/101") num )
("parse numbers in a list" (parse "(12 34.56 -17 3/4)") (12 34.56 -17 3/4) )
("parse an improper list" (parse "(a b c . d)") (a b c . d))
- ("parse a list of characters"
+ ("parse a list of characters"
(eval (parse "(coerce '(#\\( #\\a #\\b #\\space #\\c #\\ #\\d #\\)) 'string)"))
"(ab c d)")
("raise error for unrecognised chars"
(on-err (fn (ex) (details ex)) (fn () (parse "#\\spade")))
"unknown char: #\\spade")
("parse a string containing spaces"
- (parse "\"foo bar\"")
+ (parse "\"foo bar\"")
"foo bar")
("completely ignore comments"
- (parse "(foo bar) ; the foo bar\n; more commentary")
+ (parse "(foo bar) ; the foo bar\n; more commentary")
(foo bar))
("parse quote non-atom"
(parse "'(foo bar)")
'(foo bar))
("parse whitespace before closing paren"
- (parse "(foo bar )")
+ (parse "(foo bar )")
(foo bar))
("parse a nasty string containing parens and escapes"
(parse "(parse \"\\\"foo bar\\\"\")")
@@ -48,7 +48,7 @@
("parse escaped interpolations"
(coerce (parse:string "\"foo \\#" "(foo)\"") 'cons)
(#\f #\o #\o #\space #\# #\( #\f #\o #\o #\)))
- ("parse a complex expression"
+ ("parse a complex expression"
(parse "(foo bar '(toto) `(do ,blah ,@blahs \"astring\") titi)")
(foo bar '(toto) `(do ,blah ,@blahs "astring") titi))))
@@ -72,7 +72,7 @@
(syntax right-paren 1 35 )) 3))
("index an unbalanced left-paren"
- (index-source "(def foo (bar) (toto 'a \"blah\")")
+ (index-source "(def foo (bar) (toto 'a \"blah\")")
(((syntax unmatched-left-paren 0 1 )
(sym def 1 4 )
(sym foo 5 8 )
@@ -89,7 +89,7 @@
(syntax right-paren 15 31 )) 1))
("index an unbalanced left-bracket"
- (index-source "(map [disp _ val)")
+ (index-source "(map [disp _ val)")
(((syntax left-paren 0 17 )
(sym map 1 4 )
(syntax unmatched-left-bracket 5 6 )
@@ -97,9 +97,9 @@
(sym _ 11 12 )
(sym val 13 16 )
(syntax right-paren 0 17 )) 1))
-
+
("index an unbalanced right-paren"
- (index-source "(prn (foo (x) y))) (prn 'yo)")
+ (index-source "(prn (foo (x) y))) (prn 'yo)")
(((syntax left-paren 0 17 )
(sym prn 1 4 )
(syntax left-paren 5 16 )
3  src/arc/lib/unit-test.arc
View
@@ -1,3 +1,6 @@
+; This software is copyright (c) Conan Dalton 2008. Permission to use
+; it is granted under the Perl Foundations's Artistic License 2.0.
+
;; to run a test,
;;
;; arc>(run-tests '("addition" (+ 2 3) 5))
577 src/arc/news.arc
View
@@ -1,15 +1,19 @@
; News. 2 Sep 06.
-
; to run news: (nsv)
; put usernames of admins, separated by whitespace, in arc/admins
+; bug: somehow (+ votedir* nil) is getting evaluated.
+
+(declare 'atstrings t)
+
(= this-site* "My Forum"
site-url* "http://news.yourdomain.com/"
parent-url* "http://www.yourdomain.com"
favicon-url* ""
site-desc* "What this site is about." ; for rss feed
- site-color* (color 160 180 200)
+ site-color* (color 180 180 180)
+ border-color* (color 180 180 180)
prefer-url* t)
@@ -143,25 +147,11 @@
(def check-key (u k)
(and u (mem k (uvar u keys))))
-(def set-key (u k)
- (do1 (pushnew k (uvar u keys))
- (save-prof u)))
-
-(def unset-key (u k)
- (do1 (pull k (uvar u keys))
- (save-prof u)))
-
-(def toggle-key (u k)
- (do1 (atomic
- (if (mem k (uvar u keys))
- (pull k (uvar u keys))
- (push k (uvar u keys))))
- (save-prof u)))
-
(def author (u i) (is u i!by))
-(= stories* nil comments* nil items* (table) url->story* (table)
+(= stories* nil comments* nil
+ items* (table) url->story* (table)
maxid* 0 initload* 15000)
; The dir expression yields stories in order of file creation time
@@ -182,9 +172,7 @@
(noisy-each 100 id (firstn initload* ids)
(let i (load-item id)
(push i (items i!type))))
- (= stories* (rev (merge (compare < get!id)
- items!story
- items!poll))
+ (= stories* (rev (merge (compare < !id) items!story items!poll))
comments* (rev items!comment))
(hook 'initload items))
(ensure-topstories))
@@ -203,7 +191,7 @@
(def load-item (id)
(let i (temload 'item (string storydir* id))
(= (items* id) i)
- (awhen (and (astory i) (live i) (check i!url ~blank))
+ (awhen (and (astory+live i) (check i!url ~blank))
(register-url i it))
i))
@@ -219,17 +207,11 @@
(def canonical-url (url)
(if (stemmable-sites* (sitename url))
- (stem-url url)
+ (cut url 0 (pos #\? url))
url))
-(def stem-url (url)
- (cut url 0 (pos #\? url)))
-
(def new-item-id ()
- (let id (++ maxid*)
- (if (file-exists (string storydir* id))
- (new-item-id)
- id)))
+ (evtil (++ maxid*) [~file-exists (string storydir* _)]))
(def item (id)
(or (items* id) (errsafe:load-item id)))
@@ -240,8 +222,7 @@
; because people try e.g. item?id=363/blank.php
(def safe-item (id)
- (let id (if (isa id 'string) (saferead id) id)
- (and (ok-id id) (item id))))
+ (ok-id+item (if (isa id 'string) (saferead id) id)))
(def ok-id (id)
(and (exact id) (<= 1 id maxid*)))
@@ -251,8 +232,6 @@
(def live (i) (nor i!dead i!deleted))
-(def live-child (d) (find live (kids d)))
-
(def save-item (i) (save-table i (string storydir* i!id)))
(def kill (i how)
@@ -275,9 +254,7 @@
,@body)))))
(def loaded-items (test)
- (accum a
- (each-loaded-item i
- (when (test i) (a i)))))
+ (accum a (each-loaded-item i (test+a i))))
(def newslog args (apply srvlog 'news args))
@@ -311,10 +288,12 @@
(def lightweight (s)
(or (mem 'rally s!keys) ; title is a rallying cry
- (mem 'image s!keys) ; post is image(s), but without image extension
- (or (lightweights* (sitename s!url))
- (in (last (tokens s!url #\.))
- "png" "PNG" "jpg" "JPG" "jpeg" "JPEG"))))
+ (mem 'image s!keys) ; post is mainly image(s)
+ (lightweights* (sitename s!url))
+ (lightweight-url s!url)))
+
+(defmemo lightweight-url (url)
+ (in (downcase (last (tokens url #\.))) "png" "jpg" "jpeg"))
(def item-age (i) (minutes-since i!time))
@@ -327,35 +306,26 @@
(= ranked-stories* (rank-stories 180 1000 (memo frontpage-rank))))
(def save-topstories ()
- (writefile (map get!id (firstn 180 ranked-stories*))
+ (writefile (map !id (firstn 180 ranked-stories*))
(+ newsdir* "topstories")))
(def rank-stories (n consider scorefn)
- (bestn n (compare > scorefn) (recent-stories consider)))
-
-; The n most recent stories.
+ (bestn n (compare > scorefn) (latest-items metastory nil consider)))
-; with virtual lists would write thus:
-; (map item (retrieve n metastory:item (gen maxid* [- _ 1])))
+; With virtual lists the above call to latest-items could be simply:
+; (map item (retrieve consider metastory:item (gen maxid* [- _ 1])))
-(def recent-stories (n (o id maxid*) (o acc nil))
- (if (or (< n 1) (< id 1))
- (rev acc)
- (let s (item id)
- (if (metastory s)
- (recent-stories (- n 1) (- id 1) (cons s acc))
- (recent-stories n (- id 1) acc)))))
-
-(def recent-items (test minutes)
- (with (cutoff (- (seconds) (* 60 minutes))
- id nil)
- (accum a
- (loop (= id maxid*)
- (and (> id 0) (> ((item id) 'time) cutoff))
- (-- id)
+(def latest-items (test (o stop) (o n))
+ (accum a
+ (catch
+ (down id maxid* 1
(let i (item id)
- (if (test i) (a i)))))))
-
+ (if (or (and stop (stop i)) (and n (<= n 0)))
+ (throw))
+ (when (test i)
+ (a i)
+ (if n (-- n))))))))
+
; redefined later
(def metastory (i) (and i (in i!type 'story 'poll)))
@@ -417,7 +387,7 @@
; Page Layout
-(= up-url* "grayarrow.gif" down-url* "graydown.gif" logo-url* "y18.gif")
+(= up-url* "grayarrow.gif" down-url* "graydown.gif" logo-url* "arc.png")
(defopr favicon.ico req favicon-url*)
@@ -494,7 +464,9 @@
(pr msg))))
(br2)))
-; remember to (= caching* 0) or won't see changes
+(= (max-age* 'news.css) 86400) ; cache css in browser for 1 day
+
+; turn off server caching via (= caching* 0) or won't see changes
(defop news.css req
(pr "
@@ -592,6 +564,7 @@ function vote(node) {
site-color*))
(def pagetop (switch lid label (o title) (o user) (o whence))
+; (tr (tdcolor black (vspace 5)))
(tr (tdcolor (main-color user)
(tag (table border 0 cellpadding 0 cellspacing 0 width "100%"
style "padding:2px")
@@ -613,8 +586,8 @@ function vote(node) {
(def gen-logo ()
(tag (td style "width:18px;padding-right:4px")
(tag (a href parent-url*)
- (gentag img src logo-url* width 18 height 18
- style "border:1px white solid;"))))
+ (tag (img src logo-url* width 18 height 18
+ style "border:1px #@(hexrep border-color*) solid;")))))
(= toplabels* '(nil "welcome" "new" "threads" "comments" "leaders" "*"))
@@ -643,7 +616,7 @@ function vote(node) {
(def topright (user whence (o showkarma t))
(when user
(userlink user user nil)
- (when showkarma (pr "&nbsp;(" (karma user) ")"))
+ (when showkarma (pr "&nbsp;(@(karma user))"))
(pr "&nbsp;|&nbsp;"))
(if user
(rlinkf 'logout (req)
@@ -746,13 +719,13 @@ function vote(node) {
(if (profile subject)
(do (killallby subject)
(submitted-page user subject))
- (if (admin user) (newsadmin-page user)))))
+ (admin+newsadmin-page user))))
(single-input "" 'id 20 "kill all by"))
(br2)
(aform (fn (req)
(let user (get-user req)
(set-ip-ban user (arg req "ip") t)
- (if (admin user) (newsadmin-page user))))
+ (admin+newsadmin-page user)))
(single-input "" 'ip 20 "ban ip"))))
@@ -779,7 +752,10 @@ function vote(node) {
(let prof (profile subject)
(vars-form user
(user-fields user subject)
- (fn (name val) (= (prof name) val))
+ (fn (name val)
+ (when (and (is name 'ignore) val (no prof!ignore))
+ (log-ignore user subject 'profile))
+ (= (prof name) val))
(fn () (save-prof subject)
(user-page user subject)))))
@@ -814,8 +790,7 @@ function vote(node) {
(posint minaway ,(p 'minaway) ,u ,u)
(sexpr keys ,(p 'keys) ,a ,a)
(hexcol topcolor ,(or (p 'topcolor) (hexrep site-color*)) ,k ,k)
- (int delay ,(p 'delay) ,u ,u)
- )))
+ (int delay ,(p 'delay) ,u ,u))))
(def saved-link (user subject)
(when (or (admin user) (is user subject))
@@ -921,7 +896,7 @@ function vote(node) {
(row (link "bestcomments") "Highest voted recent comments.")
(row (link "noobs") "Submissions from new accounts.")
(when (admin user)
- (map [row (link _)]
+ (map row:link
'(optimes topips flagged killed badguys badlogins goodlogins)))
(hook 'listspage user))))
@@ -960,22 +935,23 @@ function vote(node) {
(spacerow 10)
(tr (tag (td colspan (if number 2 1)))
(tag (td class 'title)
- (morelink items label title end newend number))))))))
+ (morelink display-items
+ items label title end newend number))))))))
; This code is inevitably complex because the More fn needs to know
; its own fnid in order to supply a correct whence arg to stuff on
; the page it generates, like logout and delete links.
-(def morelink (items label title end newend number)
- (tag (a href (url-for
- (afnid (fn (req)
- (prn)
- (let user (get-user req)
- (newslog req!ip user 'more label)
- (longpage user (msec) nil label title (url-for it)
- (display-items user items
- label title (url-for it)
- end newend number))))))
+(def morelink (f items label title . args)
+ (tag (a href
+ (url-for
+ (afnid (fn (req)
+ (prn)
+ (with (url (url-for it) ; it bound by afnid
+ user (get-user req))
+ (newslog req!ip user 'more label)
+ (longpage user (msec) nil label title url
+ (apply f user items label title url args))))))
rel 'nofollow)
(pr "More")))
@@ -1111,8 +1087,7 @@ function vote(node) {
(def canvote (user i dir)
(and user
- (news-type i)
- (live i)
+ (news-type+live i)
(or (is dir 'up) (> i!score lowest-score*))
(no ((votes user) i!id))
(or (is dir 'up)
@@ -1162,9 +1137,7 @@ function vote(node) {
; redefined later
(def byline (i user)
- (pr " by ")
- (userlink user i!by)
- (pr " " (text-age:item-age i) " "))
+ (pr " by @(tostring (userlink user i!by)) @(text-age:item-age i) "))
(def user-url (user) (+ "user?id=" user))
@@ -1173,7 +1146,7 @@ function vote(node) {
(def userlink (user subject (o show-avg t))
(link (user-name user subject) (user-url subject))
(awhen (and show-avg* (admin user) show-avg (uvar subject avg))
- (pr " (" (num it 1 t t) ")")))
+ (pr " (@(num it 1 t t))")))
(= noob-color* (color 60 150 60))
@@ -1194,7 +1167,7 @@ function vote(node) {
(if (> n 0)
(do (pr (plural n "comment"))
(awhen (and show-threadavg* (admin user) (threadavg i))
- (pr " (" (num it 1 t t) ")")))
+ (pr " (@(num it 1 t t))")))
(pr "discuss"))))))
(def visible-family (user i)
@@ -1203,7 +1176,7 @@ function vote(node) {
(def threadavg (i)
(only.avg (map [or (uvar _ avg) 1]
- (rem admin (dedup (map get!by (keep live (family i))))))))
+ (rem admin (dedup (map !by (keep live (family i))))))))
(= user-changetime* 120 editor-changetime* 1440)
@@ -1239,25 +1212,20 @@ function vote(node) {
; over flag-kill-threshold. Ok, since arbitrary threshold anyway.
(def flaglink (i user whence)
- (when (and user
+ (when (and user
(isnt user i!by)
(or (admin user) (> (karma user) flag-threshold*)))
(pr bar*)
- (w/rlink (do (if (mem user i!flags)
- (pull user i!flags)
- (push user i!flags))
+ (w/rlink (do (togglemem user i!flags)
(when (and (~mem 'nokill i!keys)
(len> i!flags flag-kill-threshold*)
- (~find [admin _.2] i!vote))
+ (~find admin:!2 i!vote))
(kill i 'flags))
whence)
- (pr (if (mem user i!flags) "unflag" "flag")))
+ (pr "@(if (mem user i!flags) 'un)flag"))
(when (and (admin user) (len> i!flags many-flags*))
- (pr bar*)
- (pr (plural (len i!flags) "flag") " ")
- (w/rlink (do (if (mem 'nokill i!keys)
- (pull 'nokill i!keys)
- (push 'nokill i!keys))
+ (pr bar* (plural (len i!flags) "flag") " ")
+ (w/rlink (do (togglemem 'nokill i!keys)
(save-item i)
whence)
(pr (if (mem 'nokill i!keys) "un-notice" "noted"))))))
@@ -1272,7 +1240,7 @@ function vote(node) {
(pushnew 'nokill i!keys))
(save-item i)
whence)
- (pr (if i!dead "unkill" "kill")))))
+ (pr "@(if i!dead 'un)kill"))))
; Blast kills the submission and bans the user. Nuke also bans the
; site, so that all future submitters will be ignored. Does not ban
@@ -1284,8 +1252,7 @@ function vote(node) {
(pr bar*)
(w/rlink (do (toggle-blast i user nuke)
whence)
- (pr (if (ignored i!by) "un-" "")
- (if nuke "nuke" "blast")))))
+ (prt (if (ignored i!by) "un-") (if nuke "nuke" "blast")))))
(def toggle-blast (i user (o nuke))
(atomic
@@ -1293,7 +1260,8 @@ function vote(node) {
(do (wipe i!dead (ignored i!by))
(awhen (and nuke (sitename i!url))
(set-site-ban user it nil)))
- (do (set i!dead (ignored i!by))
+ (do (set i!dead)
+ (ignore user i!by (if nuke 'nuke 'blast))
(awhen (and nuke (sitename i!url))
(set-site-ban user it 'ignore))))
(if i!dead (log-kill i user))
@@ -1321,10 +1289,8 @@ function vote(node) {
(def del-confirm-page (user i whence)
(minipage "Confirm"
(tab
- (display-item nil
- i user
- ; never used so not testable but think correct
- (flink [del-confirm-page (get-user _) i whence]))
+ ; link never used so not testable but think correct
+ (display-item nil i user (flink [del-confirm-page (get-user _) i whence]))
(spacerow 20)
(tr (td)
(td (urform user req
@@ -1332,9 +1298,7 @@ function vote(node) {
(= i!deleted (is (arg req "b") "Yes"))
(save-item i))
whence)
- (prn "Do you want this to "
- (if i!deleted "remain" "be")
- " deleted?")
+ (prn "Do you want this to @(if i!deleted 'stay 'be) deleted?")
(br2)
(but "Yes" "b") (sp) (but "No" "b")))))))
@@ -1348,12 +1312,9 @@ function vote(node) {
(def text-age (a)
(tostring
- (if (>= a 1440) (let n (trunc (/ a 1440))
- (pr (plural n "day") " ago"))
- (>= a 60) (let n (trunc (/ a 60))
- (pr (plural n "hour") " ago"))
- (let n (trunc a)
- (pr (plural n "minute") " ago")))))
+ (if (>= a 1440) (pr (plural (trunc (/ a 1440)) "day") " ago")
+ (>= a 60) (pr (plural (trunc (/ a 60)) "hour") " ago")
+ (pr (plural (trunc a) "minute") " ago"))))
; Voting
@@ -1375,11 +1336,7 @@ function vote(node) {
(and (< (user-age user) new-age-threshold*)
(< (karma user) new-karma-threshold*))))
-(= downvote-ratio-limit* .65)
-
-(= recent-votes* nil)
-
-(= votewindow* 100)
+(= downvote-ratio-limit* .65 recent-votes* nil votewindow* 100)
; Note: if vote-for by one user changes (s 'score) while s is being
; edited by another, the save after the edit will overwrite the change.
@@ -1388,7 +1345,7 @@ function vote(node) {
(def vote-for (user i (o dir 'up))
(unless (or ((votes user) i!id)
- (and (isnt user i!by) (~live i)))
+ (and (~live i) (isnt user i!by)))
(withs (ip (logins* user)
vote (list (seconds) ip user dir i!score))
(unless (or (and (or (ignored user) (check-key user 'novote))
@@ -1404,17 +1361,15 @@ function vote(node) {
(find [is (cadr _) ip] i!votes))
(and (isnt i!type 'pollopt)
(biased-voter i vote)))
- (case dir up (++ i!score)
- down (-- i!score))
+ (++ i!score (case dir up 1 down -1))
; canvote protects against sockpuppet downvote of comments
(when (and (is dir 'up) (possible-sockpuppet user))
(++ i!sockvotes))
- (if (metastory i) (adjust-rank i))
+ (metastory+adjust-rank i)
(unless (or (author user i)
(and (is ip i!ip) (~editor user))
(is i!type 'pollopt))
- (case dir up (++ (karma i!by))
- down (-- (karma i!by)))
+ (++ (karma i!by) (case dir up 1 down -1))
(save-prof i!by))
(wipe (comment-cache* i!id)))
(if (admin user) (pushnew 'nokill i!keys))
@@ -1432,17 +1387,13 @@ function vote(node) {
(def biased-voter (i vote) nil)
-; ugly to use car, cadr to manipulate vote fields
+; ugly to access vote fields by position number
(def downvote-ratio (user (o sample 20))
- (let vs (keep (fn (x)
- (let by ((item (car x)) 'by)
- (nor (is by user) (ignored by))))
- (bestn sample (compare > car:cadr) (tablist (votes user))))
- (if vs
- (/ (count [is ((cadr _) 3) 'down] vs)
- (len vs))
- 0)))
+ (ratio [is _.1.3 'down]
+ (keep [let by ((item (car _)) 'by)
+ (nor (is by user) (ignored by))]
+ (bestn sample (compare > car:cadr) (tablist (votes user))))))
(def just-downvoted (user victim (o n 3))
(let prev (firstn n (recent-votes-by user))
@@ -1456,7 +1407,7 @@ function vote(node) {
; in one with the voter in the car and the other without.
(def recent-votes-by (user)
- (keep [is (_ 3) user] recent-votes*))
+ (keep [is _.3 user] recent-votes*))
; Story Submission
@@ -1507,13 +1458,13 @@ function vote(node) {
; Added a confirm step to avoid xss hacks.
(newsop submitlink (u t)
- (if user
+ (if user
(submit-page user u t)
(submit-login-warning u t)))
(= title-limit* 80
retry* "Please try again."
- toolong* (string "Please make title < " title-limit* " characters.")
+ toolong* "Please make title < @title-limit* characters."
bothblank* "The url and text fields can't both be blank. Please
either supply a url, or if you're asking a question,
put it in the text field."
@@ -1538,9 +1489,10 @@ function vote(node) {
(flink [submit-page user url title showtext text toolong*])
(and (blank url) (blank text))
(flink [submit-page user url title showtext text bothblank*])
- (big-spamsites* (sitename url))
+ (let site (sitename url)
+ (or (big-spamsites* site) (recent-spam site)))
(flink [msgpage user spammage*])
- (oversubmitting user ip 'story)
+ (oversubmitting user ip 'story url)
(flink [msgpage user toofast*])
(let s (create-story url (process-title title) text user ip)
(story-ban-test user s ip url)
@@ -1554,6 +1506,14 @@ function vote(node) {
(save-prof user)
(vote-for user i))
+(def recent-spam (site)
+ (and (caris (banned-sites* site) 'ignore)
+ (recent-items [is (sitename _!url) site] 720)))
+
+(def recent-items (test minutes)
+ (let cutoff (- (seconds) (* 60 minutes))
+ (latest-items test [< _!time cutoff])))
+
; Turn this on when spam becomes a problem.
(= enforce-oversubmit* nil)
@@ -1561,16 +1521,16 @@ function vote(node) {
; New user can't submit more than 2 stories in a 2 hour period.
; Give overeager users the key toofast to make limit permanent.
-(def oversubmitting (user ip (o kind 'story))
+(def oversubmitting (user ip kind (o url))
(and enforce-oversubmit*
(or (check-key user 'toofast)
(ignored user)
(< (user-age user) new-age-threshold*)
(< (karma user) new-karma-threshold*))
- (len> (recent-items [or (author user _) (is _!ip ip)] 120)
+ (len> (recent-items [or (author user _) (is _!ip ip)] 180)
(if (is kind 'story)
(if (ignored user) 0 1)
- (if (ignored user) 2 10)))))
+ (if (ignored user) 1 10)))))
; Note that by deliberate tricks, someone could submit a story with a
; blank title.