API tools faq
paste
Advertisement
Guest User

Untitled

a guest
Jan 10th, 2012
87
0
Never
Add comment
Not a member of Pastebin yet? Sign Up, it unlocks many cool features!
Scheme 43.37 KB | None | 0 0
raw download clone embed print report
  1. --- ac.scm      2012-01-09 11:22:45.232049658 +0100
  2. +++ ac.scm.old  2012-01-10 18:16:11.695306289 +0100
  3. @@ -9,44 +9,18 @@
  4.  (require (lib "foreign.ss"))
  5.  (unsafe!)
  6.  
  7. -(define main-namespace (current-namespace))
  8. -
  9. -(define (ac-global-name s)
  10. -  (string->symbol (string-append "_" (symbol->string s))))
  11. -
  12. -(define-syntax defarc
  13. -  (syntax-rules ()
  14. -    ((defarc (name . args) body ...)
  15. -     (defarc name (name . args) body ...))
  16. -    ((defarc arc-name (scheme-name . args) body ...)
  17. -     (begin
  18. -       (xdef arc-name (lambda args body ...))
  19. -       (defarc arc-name scheme-name)))
  20. -    ((defarc arc-name scheme-name)
  21. -     (define (scheme-name . args)
  22. -
  23. -       ; The following 'parameterize has been added. See the note at
  24. -       ; 'arc-exec, below.
  25. -       ;
  26. -       (apply (parameterize ((current-namespace main-namespace))
  27. -                (namespace-variable-value (ac-global-name 'arc-name)))
  28. -              args)))
  29. -    ((defarc name)
  30. -     (defarc name name))))
  31. -
  32.  ; compile an Arc expression into a Scheme expression,
  33.  ; both represented as s-expressions.
  34.  ; env is a list of lexically bound variables, which we
  35.  ; need in order to decide whether set should create a global.
  36.  
  37. -(defarc (ac s env)
  38. +(define (ac s env)
  39.    (cond ((string? s) (ac-string s env))
  40.          ((literal? s) s)
  41.          ((eqv? s 'nil) (list 'quote 'nil))
  42.          ((ssyntax? s) (ac (expand-ssyntax s) env))
  43.          ((symbol? s) (ac-var-ref s env))
  44.          ((ssyntax? (xcar s)) (ac (cons (expand-ssyntax (car s)) (cdr s)) env))
  45. -        ((eq? (xcar s) '$) (ac-$ (cadr s) env))
  46.          ((eq? (xcar s) 'quote) (list 'quote (ac-niltree (cadr s))))
  47.          ((eq? (xcar s) 'quasiquote) (ac-qq (cadr s) env))
  48.          ((eq? (xcar s) 'if) (ac-if (cdr s) env))
  49. @@ -56,14 +30,16 @@
  50.          ; ... except that they work for macros (so prob should do this for
  51.          ; every elt of s, not just the car)
  52.          ((eq? (xcar (xcar s)) 'compose) (ac (decompose (cdar s) (cdr s)) env))
  53. -        ((eq? (xcar (xcar s)) 'complement)
  54. +        ((eq? (xcar (xcar s)) 'complement)
  55.           (ac (list 'no (cons (cadar s) (cdr s))) env))
  56.          ((eq? (xcar (xcar s)) 'andf) (ac-andf s env))
  57.          ((pair? s) (ac-call (car s) (cdr s) env))
  58.          (#t (err "Bad object in expression" s))))
  59.  
  60. +(define atstrings #f)
  61. +
  62.  (define (ac-string s env)
  63. -  (if (ar-bflag 'atstrings)
  64. +  (if atstrings
  65.        (if (atpos s 0)
  66.            (ac (cons 'string (map (lambda (x)
  67.                                     (if (string? x)
  68. @@ -74,7 +50,7 @@
  69.            (unescape-ats s))
  70.        (string-copy s)))          ; avoid immutable strings
  71.  
  72. -(defarc ac-literal (literal? x)
  73. +(define (literal? x)
  74.    (or (boolean? x)
  75.        (char? x)
  76.        (string? x)
  77. @@ -90,9 +66,9 @@
  78.  (define (has-ssyntax-char? string i)
  79.    (and (>= i 0)
  80.         (or (let ((c (string-ref string i)))
  81. -             (or (eqv? c #\:) (eqv? c #\~)
  82. +             (or (eqv? c #\:) (eqv? c #\~)
  83.                   (eqv? c #\&)
  84. -                 ;(eqv? c #\_)
  85. +                 ;(eqv? c #\_)
  86.                   (eqv? c #\.)  (eqv? c #\!)))
  87.             (has-ssyntax-char? string (- i 1)))))
  88.  
  89. @@ -107,7 +83,7 @@
  90.  ; leave this off and see how often it would have been useful.
  91.  
  92.  ; Might want to make ~ have less precedence than &, because
  93. -; ~foo&bar prob should mean (andf (complement foo) bar), not
  94. +; ~foo&bar prob should mean (andf (complement foo) bar), not
  95.  ; (complement (andf foo bar)).
  96.  
  97.  (define (expand-ssyntax sym)
  98. @@ -126,9 +102,9 @@
  99.                               `(complement ,(chars->value (cdr tok))))
  100.                           (chars->value tok)))
  101.                     (tokens (lambda (c) (eqv? c #\:))
  102. -                           (symbol->chars sym)
  103. -                           '()
  104. -                           '()
  105. +                           (symbol->chars sym)
  106. +                           '()
  107. +                           '()
  108.                             #f))))
  109.      (if (null? (cdr elts))
  110.          (car elts)
  111. @@ -145,26 +121,26 @@
  112.          (car elts)
  113.          (cons 'andf elts))))
  114.  
  115. -; How to include quoted arguments?  Can't treat all as quoted, because
  116. -; never want to quote fn given as first.  Do we want to allow quote chars
  117. -; within symbols?  Could be ugly.
  118. +; How to include quoted arguments?  Can't treat all as quoted, because
  119. +; never want to quote fn given as first.  Do we want to allow quote chars
  120. +; within symbols?  Could be ugly.  
  121.  
  122.  ; If release, fix the fact that this simply uses v0... as vars.  Should
  123.  ; make these vars gensyms.
  124.  
  125.  (define (expand-curry sym)
  126. -  (let ((expr (exc (map (lambda (x)
  127. +  (let ((expr (exc (map (lambda (x)
  128.                            (if (pair? x) (chars->value x) x))
  129. -                        (tokens (lambda (c) (eqv? c #\_))
  130. -                                (symbol->chars sym)
  131. -                                '()
  132. -                                '()
  133. +                        (tokens (lambda (c) (eqv? c #\_))
  134. +                                (symbol->chars sym)
  135. +                                '()
  136. +                                '()
  137.                                  #t))
  138.                      0)))
  139. -    (list 'fn
  140. -          (keep (lambda (s)
  141. -                  (and (symbol? s)
  142. -                       (eqv? (string-ref (symbol->string s) 0)
  143. +    (list 'fn
  144. +          (keep (lambda (s)
  145. +                  (and (symbol? s)
  146. +                       (eqv? (string-ref (symbol->string s) 0)
  147.                               #\v)))
  148.                  expr)
  149.            expr)))
  150. @@ -212,7 +188,7 @@
  151.  
  152.  (define (tokens test source token acc keepsep?)
  153.    (cond ((null? source)
  154. -         (reverse (if (pair? token)
  155. +         (reverse (if (pair? token)
  156.                        (cons (reverse token) acc)
  157.                        acc)))
  158.          ((test (car source))
  159. @@ -233,44 +209,36 @@
  160.                   acc
  161.                   keepsep?))))
  162.  
  163. -(defarc (ac-defined-var? s)
  164. -  #f)
  165. +(define (ac-global-name s)
  166. +  (string->symbol (string-append "_" (symbol->string s))))
  167.  
  168.  (define (ac-var-ref s env)
  169. -  (cond ((lex? s env)        s)
  170. -        ((ac-defined-var? s) (list (ac-global-name s)))
  171. -        (#t                  (ac-global-name s))))
  172. -
  173. -; lowering into mzscheme, with (unquote <foo>) lifting us back into arc
  174. -
  175. -(define (ac-$ args env)
  176. -  (ac-qqx args
  177. -    (lambda (x) (ac x env))
  178. -    (lambda (x) (error 'ac-$ "Can't use ,@ from within $ in: ~a" args))))
  179. +  (if (lex? s env)
  180. +      s
  181. +      (ac-global-name s)))
  182.  
  183.  ; quasiquote
  184.  
  185.  (define (ac-qq args env)
  186. -  (list 'quasiquote (ac-qqx args
  187. -                      (lambda (x) (list 'unquote (ac x env)))
  188. -                      (lambda (x) (list 'unquote-splicing
  189. -                                    (list 'ar-nil-terminate (ac x env)))))))
  190. +  (list 'quasiquote (ac-qq1 1 args env)))
  191.  
  192.  ; process the argument of a quasiquote. keep track of
  193.  ; depth of nesting. handle unquote only at top level (level = 1).
  194.  ; complete form, e.g. x or (fn x) or (unquote (fn x))
  195.  
  196. -(define (ac-qqx x unq splice)
  197. -  (cond
  198. -    ((not (pair? x)) x)
  199. -    ((eqv? (car x) 'unquote) (unq (cadr x)))
  200. -    ((eqv? (car x) 'unquote-splicing) (splice (cadr x)))
  201. -    ((eqv? (car x) 'quasiquote)
  202. -      (list 'quasiquote
  203. -        (ac-qqx (cadr x)
  204. -          (lambda (e) (list 'unquote (ac-qqx e unq splice)))
  205. -          (lambda (e) (list 'unquote-splicing (ac-qqx e unq splice))))))
  206. -    (#t (imap (lambda (e) (ac-qqx e unq splice)) x))))
  207. +(define (ac-qq1 level x env)
  208. +  (cond ((= level 0)
  209. +         (ac x env))
  210. +        ((and (pair? x) (eqv? (car x) 'unquote))
  211. +         (list 'unquote (ac-qq1 (- level 1) (cadr x) env)))
  212. +        ((and (pair? x) (eqv? (car x) 'unquote-splicing) (= level 1))
  213. +         (list 'unquote-splicing
  214. +               (list 'ar-nil-terminate (ac-qq1 (- level 1) (cadr x) env))))
  215. +        ((and (pair? x) (eqv? (car x) 'quasiquote))
  216. +         (list 'quasiquote (ac-qq1 (+ level 1) (cadr x) env)))
  217. +        ((pair? x)
  218. +         (imap (lambda (x) (ac-qq1 level x env)) x))
  219. +        (#t x)))
  220.  
  221.  ; like map, but don't demand '()-terminated list
  222.  
  223. @@ -332,7 +300,7 @@
  224.  ; be missing.
  225.  
  226.  (define (ac-complex-fn args body env)
  227. -  (let* ((ra (gensym))
  228. +  (let* ((ra (ar-gensym))
  229.           (z (ac-complex-args args env ra #t)))
  230.      `(lambda ,ra
  231.         (let* ,z
  232. @@ -350,11 +318,11 @@
  233.          ((symbol? args) (list (list args ra)))
  234.          ((pair? args)
  235.           (let* ((x (if (and (pair? (car args)) (eqv? (caar args) 'o))
  236. -                       (ac-complex-opt (cadar args)
  237. +                       (ac-complex-opt (cadar args)
  238.                                         (if (pair? (cddar args))
  239. -                                           (caddar args)
  240. +                                           (caddar args)
  241.                                             'nil)
  242. -                                       env
  243. +                                       env
  244.                                         ra)
  245.                         (ac-complex-args
  246.                          (car args)
  247. @@ -431,13 +399,8 @@
  248.                 (cond ((eqv? a 'nil) (err "Can't rebind nil"))
  249.                       ((eqv? a 't) (err "Can't rebind t"))
  250.                       ((lex? a env) `(set! ,a zz))
  251. -                     ((ac-defined-var? a) `(,(ac-global-name a) zz))
  252. -
  253. -                     ; The following has been changed from
  254. -                     ; 'namespace-set-variable-value! to 'set!. See
  255. -                     ; the note at 'arc-exec, below.
  256. -                     ;
  257. -                     (#t `(set! ,(ac-global-name a) zz)))
  258. +                     (#t `(namespace-set-variable-value! ',(ac-global-name a)
  259. +                                                         zz)))
  260.                 'zz))
  261.        (err "First arg to set must be a symbol" a)))
  262.  
  263. @@ -468,9 +431,9 @@
  264.  (define (ac-global-call fn args env)
  265.    (cond ((and (assoc fn ac-binaries) (= (length args) 2))
  266.           `(,(cadr (assoc fn ac-binaries)) ,@(ac-args '() args env)))
  267. -        (#t
  268. +        (#t
  269.           `(,(ac-global-name fn) ,@(ac-args '() args env)))))
  270. -
  271. +      
  272.  ; compile a function call
  273.  ; special cases for speed, to avoid compiled output like
  274.  ;   (ar-apply _pr (list 1 2))
  275. @@ -480,23 +443,30 @@
  276.  ;   and it's bound to a function, generate (foo bar) instead of
  277.  ;   (ar-funcall1 foo bar)
  278.  
  279. +(define direct-calls #f)
  280. +
  281.  (define (ac-call fn args env)
  282.    (let ((macfn (ac-macro? fn)))
  283.      (cond (macfn
  284.             (ac-mac-call macfn args env))
  285.            ((and (pair? fn) (eqv? (car fn) 'fn))
  286.             `(,(ac fn env) ,@(ac-args (cadr fn) args env)))
  287. -          ((and (ar-bflag 'direct-calls) (symbol? fn) (not (lex? fn env)) (bound? fn)
  288. -
  289. -                ; The following has been changed from using
  290. -                ; 'namespace-variable-value to using 'arc-eval. See
  291. -                ; the note at 'arc-exec, below.
  292. -                ;
  293. -                (procedure? (arc-eval fn)))
  294. +          ((and direct-calls (symbol? fn) (not (lex? fn env)) (bound? fn)
  295. +                (procedure? (namespace-variable-value (ac-global-name fn))))
  296.             (ac-global-call fn args env))
  297. +          ((= (length args) 0)
  298. +           `(ar-funcall0 ,(ac fn env) ,@(map (lambda (x) (ac x env)) args)))
  299. +          ((= (length args) 1)
  300. +           `(ar-funcall1 ,(ac fn env) ,@(map (lambda (x) (ac x env)) args)))
  301. +          ((= (length args) 2)
  302. +           `(ar-funcall2 ,(ac fn env) ,@(map (lambda (x) (ac x env)) args)))
  303. +          ((= (length args) 3)
  304. +           `(ar-funcall3 ,(ac fn env) ,@(map (lambda (x) (ac x env)) args)))
  305. +          ((= (length args) 4)
  306. +           `(ar-funcall4 ,(ac fn env) ,@(map (lambda (x) (ac x env)) args)))
  307.            (#t
  308. -           `((ar-coerce ,(ac fn env) 'fn)
  309. -             ,@(map (lambda (x) (ac x env)) args))))))
  310. +           `(ar-apply ,(ac fn env)
  311. +                      (list ,@(map (lambda (x) (ac x env)) args)))))))
  312.  
  313.  (define (ac-mac-call m args env)
  314.    (let ((x1 (apply m (map ac-niltree args))))
  315. @@ -507,12 +477,9 @@
  316.  
  317.  (define (ac-macro? fn)
  318.    (if (symbol? fn)
  319. -
  320. -      ; The following has been changed from using
  321. -      ; 'namespace-variable-value to using 'bound? and 'arc-eval. See
  322. -      ; the note at 'arc-exec, below.
  323. -      ;
  324. -      (let ((v (and (bound? fn) (arc-eval fn))))
  325. +      (let ((v (namespace-variable-value (ac-global-name fn)
  326. +                                         #t
  327. +                                         (lambda () #f))))
  328.          (if (and v
  329.                   (ar-tagged? v)
  330.                   (eq? (ar-type v) 'mac))
  331. @@ -541,11 +508,6 @@
  332.  
  333.  (define (ac-denil x)
  334.    (cond ((pair? x) (cons (ac-denil-car (car x)) (ac-denil-cdr (cdr x))))
  335. -        ((hash-table? x)
  336. -         (let ((xc (make-hash-table 'equal)))
  337. -           (hash-table-for-each x
  338. -             (lambda (k v) (hash-table-put! xc (ac-denil k) (ac-denil v))))
  339. -           xc))
  340.          (#t x)))
  341.  
  342.  (define (ac-denil-car x)
  343. @@ -581,9 +543,9 @@
  344.  ; need ar-nil-terminate).
  345.  
  346.  (define (ac-niltree x)
  347. -  (cond ((pair? x)   (cons (ac-niltree (car x)) (ac-niltree (cdr x))))
  348. -        ((or (eq? x #f) (eq? x '()) (void? x))   'nil)
  349. -        (#t   x)))
  350. +  (cond ((pair? x) (cons (ac-niltree (car x)) (ac-niltree (cdr x))))
  351. +        ((or (eq? x #f) (eq? x '())) 'nil)
  352. +        (#t x)))
  353.  
  354.  ; The next two are optimizations, except work for macros.
  355.  
  356. @@ -593,7 +555,7 @@
  357.          (#t (list (car fns) (decompose (cdr fns) args)))))
  358.  
  359.  (define (ac-andf s env)
  360. -  (ac (let ((gs (map (lambda (x) (gensym)) (cdr s))))
  361. +  (ac (let ((gs (map (lambda (x) (ar-gensym)) (cdr s))))
  362.                 `((fn ,gs
  363.                     (and ,@(map (lambda (f) `(,f ,@gs))
  364.                                 (cdar s))))
  365. @@ -636,7 +598,7 @@
  366.    (if (or (eqv? x 'nil) (eqv? x '()))
  367.        'nil
  368.        (car x)))
  369. -
  370. +      
  371.  (define (ar-xcdr x)
  372.    (if (or (eqv? x 'nil) (eqv? x '()))
  373.        'nil
  374. @@ -659,23 +621,64 @@
  375.  ; call a function or perform an array ref, hash ref, &c
  376.  
  377.  ; Non-fn constants in functional position are valuable real estate, so
  378. -; should figure out the best way to exploit it.  What could (1 foo) or
  379. +; should figure out the best way to exploit it.  What could (1 foo) or
  380.  ; ('a foo) mean?  Maybe it should mean currying.
  381.  
  382.  ; For now the way to make the default val of a hash table be other than
  383.  ; nil is to supply the val when doing the lookup.  Later may also let
  384. -; defaults be supplied as an arg to table.  To implement this, need: an
  385. -; eq table within scheme mapping tables to defaults, and to adapt the
  386. -; code in arc.arc that reads and writes tables to read and write their
  387. -; default vals with them.  To make compatible with existing written tables,
  388. +; defaults be supplied as an arg to table.  To implement this, need: an
  389. +; eq table within scheme mapping tables to defaults, and to adapt the
  390. +; code in arc.arc that reads and writes tables to read and write their
  391. +; default vals with them.  To make compatible with existing written tables,
  392.  ; just use an atom or 3-elt list to keep the default.
  393.  
  394.  (define (ar-apply fn args)
  395. -  (apply (ar-coerce fn 'fn) args))
  396. +  (cond ((procedure? fn)
  397. +         (apply fn args))
  398. +        ((pair? fn)
  399. +         (list-ref fn (car args)))
  400. +        ((string? fn)
  401. +         (string-ref fn (car args)))
  402. +        ((hash-table? fn)
  403. +         (ar-nill (hash-table-get fn
  404. +                                  (car args)
  405. +                                  (if (pair? (cdr args)) (cadr args) #f))))
  406. +; experiment: means e.g. [1] is a constant fn
  407. +;       ((or (number? fn) (symbol? fn)) fn)
  408. +; another possibility: constant in functional pos means it gets
  409. +; passed to the first arg, i.e. ('kids item) means (item 'kids).
  410. +        (#t (err "Function call on inappropriate object" fn args))))
  411.  
  412.  (xdef apply (lambda (fn . args)
  413.                 (ar-apply fn (ar-apply-args args))))
  414.  
  415. +; special cases of ar-apply for speed and to avoid consing arg lists
  416. +
  417. +(define (ar-funcall0 fn)
  418. +  (if (procedure? fn)
  419. +      (fn)
  420. +      (ar-apply fn (list))))
  421. +
  422. +(define (ar-funcall1 fn arg1)
  423. +  (if (procedure? fn)
  424. +      (fn arg1)
  425. +      (ar-apply fn (list arg1))))
  426. +
  427. +(define (ar-funcall2 fn arg1 arg2)
  428. +  (if (procedure? fn)
  429. +      (fn arg1 arg2)
  430. +      (ar-apply fn (list arg1 arg2))))
  431. +
  432. +(define (ar-funcall3 fn arg1 arg2 arg3)
  433. +  (if (procedure? fn)
  434. +      (fn arg1 arg2 arg3)
  435. +      (ar-apply fn (list arg1 arg2 arg3))))
  436. +
  437. +(define (ar-funcall4 fn arg1 arg2 arg3 arg4)
  438. +  (if (procedure? fn)
  439. +      (fn arg1 arg2 arg3 arg4)
  440. +      (ar-apply fn (list arg1 arg2 arg3 arg4))))
  441. +
  442.  ; replace the nil at the end of a list with a '()
  443.  
  444.  (define (ar-nil-terminate l)
  445. @@ -719,7 +722,7 @@
  446.  ; (pairwise pred '(a b c d)) =>
  447.  ;   (and (pred a b) (pred b c) (pred c d))
  448.  ; pred returns t/nil, as does pairwise
  449. -; reduce?
  450. +; reduce?
  451.  
  452.  (define (pairwise pred lst)
  453.    (cond ((null? lst) 't)
  454. @@ -748,21 +751,21 @@
  455.  (xdef t   't)
  456.  
  457.  (define (all test seq)
  458. -  (or (null? seq)
  459. +  (or (null? seq)
  460.        (and (test (car seq)) (all test (cdr seq)))))
  461.  
  462.  (define (arc-list? x) (or (pair? x) (eqv? x 'nil) (eqv? x '())))
  463. -
  464. +      
  465.  ; Generic +: strings, lists, numbers.
  466.  ; Return val has same type as first argument.
  467.  
  468.  (xdef + (lambda args
  469.             (cond ((null? args) 0)
  470.                   ((char-or-string? (car args))
  471. -                  (apply string-append
  472. +                  (apply string-append
  473.                           (map (lambda (a) (ar-coerce a 'string))
  474.                                args)))
  475. -                 ((arc-list? (car args))
  476. +                 ((arc-list? (car args))
  477.                    (ac-niltree (apply append (map ar-nil-terminate args))))
  478.                   (#t (apply + args)))))
  479.  
  480. @@ -838,7 +841,6 @@
  481.          ((tcp-listener? x)  'socket)
  482.          ((exn? x)           'exception)
  483.          ((thread? x)        'thread)
  484. -        ((thread-cell? x)   'thread-cell)
  485.          (#t                 (err "Type: unknown type" x))))
  486.  (xdef type ar-type)
  487.  
  488. @@ -849,14 +851,22 @@
  489.  
  490.  (xdef rep ar-rep)
  491.  
  492. -(xdef uniq gensym)
  493. +; currently rather a joke: returns interned symbols
  494. +
  495. +(define ar-gensym-count 0)
  496. +
  497. +(define (ar-gensym)
  498. +  (set! ar-gensym-count (+ ar-gensym-count 1))
  499. +  (string->symbol (string-append "gs" (number->string ar-gensym-count))))
  500. +
  501. +(xdef uniq ar-gensym)
  502.  
  503.  (xdef ccc call-with-current-continuation)
  504.  
  505.  (xdef infile  open-input-file)
  506.  
  507. -(xdef outfile (lambda (f . args)
  508. -                 (open-output-file f
  509. +(xdef outfile (lambda (f . args)
  510. +                 (open-output-file f
  511.                                     'text
  512.                                     (if (equal? args '(append))
  513.                                         'append
  514. @@ -870,7 +880,7 @@
  515.  (xdef inside get-output-string)
  516.  
  517.  (xdef stdout current-output-port)  ; should be a vars
  518. -(xdef stdin  current-input-port)
  519. +(xdef stdin  current-input-port)
  520.  (xdef stderr current-error-port)
  521.  
  522.  (xdef call-w/stdout
  523. @@ -887,11 +897,6 @@
  524.                                        (current-input-port)))))
  525.                  (if (eof-object? c) 'nil c))))
  526.  
  527. -(xdef readchars (lambda (n . str)
  528. -                  (let ((cs (read-string n (if (pair? str)
  529. -                                              (car str)
  530. -                                              (current-input-port)))))
  531. -                    (if (eof-object? cs) 'nil (string->list cs)))))
  532.  
  533.  (xdef readb (lambda str
  534.                (let ((c (read-byte (if (pair? str)
  535. @@ -899,38 +904,27 @@
  536.                                        (current-input-port)))))
  537.                  (if (eof-object? c) 'nil c))))
  538.  
  539. -(xdef readbytes (lambda (n . str)
  540. -                  (let ((bs (read-bytes n (if (pair? str)
  541. -                                              (car str)
  542. -                                              (current-input-port)))))
  543. -                    (if (eof-object? bs) 'nil (bytes->list bs)))))
  544. -
  545. -(xdef peekc (lambda str
  546. +(xdef peekc (lambda str
  547.                (let ((c (peek-char (if (pair? str)
  548.                                        (car str)
  549.                                        (current-input-port)))))
  550.                  (if (eof-object? c) 'nil c))))
  551.  
  552. -(xdef writec (lambda (c . args)
  553. -                (write-char c
  554. -                            (if (pair? args)
  555. -                                (car args)
  556. +(xdef writec (lambda (c . args)
  557. +                (write-char c
  558. +                            (if (pair? args)
  559. +                                (car args)
  560.                                  (current-output-port)))
  561.                  c))
  562.  
  563. -(xdef writeb (lambda (b . args)
  564. -                (write-byte b
  565. -                            (if (pair? args)
  566. -                                (car args)
  567. +(xdef writeb (lambda (b . args)
  568. +                (write-byte b
  569. +                            (if (pair? args)
  570. +                                (car args)
  571.                                  (current-output-port)))
  572.                  b))
  573.  
  574. -(xdef writebytes (lambda (bs . args)
  575. -                   (write-bytes (list->bytes (ac-denil bs))
  576. -                                (if (pair? args)
  577. -                                    (car args)
  578. -                                    (current-output-port)))
  579. -                   bs))
  580. +(define explicit-flush #f)
  581.  
  582.  (define (printwith f args)
  583.    (let ((port (if (> (length args) 1)
  584. @@ -938,11 +932,10 @@
  585.                    (current-output-port))))
  586.      (when (pair? args)
  587.        (f (ac-denil (car args)) port))
  588. -    (unless (ar-bflag 'explicit-flush)
  589. -      (flush-output port)))
  590. +    (unless explicit-flush (flush-output port)))
  591.    'nil)
  592.  
  593. -(defarc write (arc-write . args) (printwith write args))
  594. +(xdef write (lambda args (printwith write   args)))
  595.  (xdef disp  (lambda args (printwith display args)))
  596.  
  597.  ; sread = scheme read. eventually replace by writing read
  598. @@ -958,109 +951,81 @@
  599.  
  600.  (define (iround x) (inexact->exact (round x)))
  601.  
  602. -; look up first by target type, then by source type
  603. -(define coercions (make-hash-table 'equal))
  604. -
  605. -(for-each (lambda (e)
  606. -            (let ((target-type (car e))
  607. -                  (conversions (make-hash-table 'equal)))
  608. -              (hash-table-put! coercions target-type conversions)
  609. -              (for-each
  610. -               (lambda (x) (hash-table-put! conversions (car x) (cadr x)))
  611. -               (cdr e))))
  612. - `((fn      (cons   ,(lambda (l) (lambda (i) (list-ref l i))))
  613. -            (string ,(lambda (s) (lambda (i) (string-ref s i))))
  614. -            (table  ,(lambda (h) (case-lambda
  615. -                                  ((k) (hash-table-get h k 'nil))
  616. -                                  ((k d) (hash-table-get h k d))))))
  617. -
  618. -   (string  (int    ,number->string)
  619. -            (num    ,number->string)
  620. -            (char   ,string)
  621. -            (cons   ,(lambda (l) (apply string-append
  622. -                                        (map (lambda (y) (ar-coerce y 'string))
  623. -                                             (ar-nil-terminate l)))))
  624. -            (sym    ,(lambda (x) (if (eqv? x 'nil) "" (symbol->string x)))))
  625. -
  626. -   (sym     (string ,string->symbol)
  627. -            (char   ,(lambda (c) (string->symbol (string c)))))
  628. -
  629. -   (int     (char   ,(lambda (c . args) (char->ascii c)))
  630. -            (num    ,(lambda (x . args) (iround x)))
  631. -            (string ,(lambda (x . args)
  632. -                       (let ((n (apply string->number x args)))
  633. -                         (if n (iround n)
  634. -                             (err "Can't coerce " x 'int))))))
  635. -
  636. -   (num     (string ,(lambda (x . args)
  637. -                       (or (apply string->number x args)
  638. -                           (err "Can't coerce " x 'num))))
  639. -            (int    ,(lambda (x) x)))
  640. -
  641. -   (cons    (string ,(lambda (x) (ac-niltree (string->list x)))))
  642. -
  643. -   (char    (int    ,ascii->char)
  644. -            (num    ,(lambda (x) (ascii->char (iround x)))))))
  645. -
  646.  (define (ar-coerce x type . args)
  647. -  (let ((x-type (ar-type x)))
  648. -    (if (eqv? type x-type) x
  649. -        (let* ((fail        (lambda () (err "Can't coerce " x type)))
  650. -               (conversions (hash-table-get coercions type fail))
  651. -               (converter   (hash-table-get conversions x-type fail)))
  652. -          (ar-apply converter (cons x args))))))
  653. +  (cond
  654. +    ((ar-tagged? x) (err "Can't coerce annotated object"))
  655. +    ((eqv? type (ar-type x)) x)
  656. +    ((char? x)      (case type
  657. +                      ((int)     (char->ascii x))
  658. +                      ((string)  (string x))
  659. +                      ((sym)     (string->symbol (string x)))
  660. +                      (else      (err "Can't coerce" x type))))
  661. +    ((exint? x)     (case type
  662. +                      ((num)     x)
  663. +                      ((char)    (ascii->char x))
  664. +                      ((string)  (apply number->string x args))
  665. +                      (else      (err "Can't coerce" x type))))
  666. +    ((number? x)    (case type
  667. +                      ((int)     (iround x))
  668. +                      ((char)    (ascii->char (iround x)))
  669. +                      ((string)  (apply number->string x args))
  670. +                      (else      (err "Can't coerce" x type))))
  671. +    ((string? x)    (case type
  672. +                      ((sym)     (string->symbol x))
  673. +                      ((cons)    (ac-niltree (string->list x)))
  674. +                      ((num)     (or (apply string->number x args)
  675. +                                     (err "Can't coerce" x type)))
  676. +                      ((int)     (let ((n (apply string->number x args)))
  677. +                                   (if n
  678. +                                       (iround n)
  679. +                                       (err "Can't coerce" x type))))
  680. +                      (else      (err "Can't coerce" x type))))
  681. +    ((pair? x)      (case type
  682. +                      ((string)  (apply string-append
  683. +                                        (map (lambda (y) (ar-coerce y 'string))
  684. +                                             (ar-nil-terminate x))))
  685. +                      (else      (err "Can't coerce" x type))))
  686. +    ((eqv? x 'nil)  (case type
  687. +                      ((string)  "")
  688. +                      (else      (err "Can't coerce" x type))))
  689. +    ((null? x)      (case type
  690. +                      ((string)  "")
  691. +                      (else      (err "Can't coerce" x type))))
  692. +    ((symbol? x)    (case type
  693. +                      ((string)  (symbol->string x))
  694. +                      (else      (err "Can't coerce" x type))))
  695. +    (#t             x)))
  696.  
  697.  (xdef coerce ar-coerce)
  698. -(xdef coerce* coercions)
  699.  
  700. -(xdef parameter make-parameter)
  701. -(xdef parameterize-sub
  702. -      (lambda (var val thunk)
  703. -        (parameterize ((var val)) (thunk))))
  704. -
  705. -(xdef open-socket  (lambda (num) (tcp-listen num 50 #t)))
  706. -
  707. -(define (ar-init-socket init-fn . args)
  708. -  (let ((oc (current-custodian))
  709. -        (nc (make-custodian)))
  710. -    (current-custodian nc)
  711. -    (apply
  712. -      (lambda (in out . tail)
  713. -        (current-custodian oc)
  714. -        (associate-custodian nc in out)
  715. -        (list* in out tail))
  716. -      (call-with-values
  717. -        init-fn
  718. -        (if (pair? args)
  719. -            (car args)
  720. -            list)))))
  721. +(xdef open-socket  (lambda (num) (tcp-listen num 50 #t)))
  722.  
  723.  ; the 2050 means http requests currently capped at 2 meg
  724.  ; http://list.cs.brown.edu/pipermail/plt-scheme/2005-August/009414.html
  725.  
  726.  (xdef socket-accept (lambda (s)
  727. -                      (ar-init-socket
  728. -                        (lambda () (tcp-accept s))
  729. -                        (lambda (in out)
  730. -                          (list (make-limited-input-port in 100000 #t)
  731. -                                out
  732. -                                (let-values (((us them) (tcp-addresses out)))
  733. -                                  them))))))
  734. -
  735. -(xdef socket-connect (lambda (host port)
  736. -                       (ar-init-socket
  737. -                         (lambda () (tcp-connect host port)))))
  738. +                      (let ((oc (current-custodian))
  739. +                            (nc (make-custodian)))
  740. +                        (current-custodian nc)
  741. +                        (call-with-values
  742. +                         (lambda () (tcp-accept s))
  743. +                         (lambda (in out)
  744. +                           (let ((in1 (make-limited-input-port in 100000 #t)))
  745. +                             (current-custodian oc)
  746. +                             (associate-custodian nc in1 out)
  747. +                             (list in1
  748. +                                   out
  749. +                                   (let-values (((us them) (tcp-addresses out)))
  750. +                                               them))))))))
  751.  
  752.  ; allow Arc to give up root privileges after it
  753.  ; calls open-socket. thanks, Eli!
  754. -(define setuid (get-ffi-obj 'setuid #f (_fun _int -> _int)
  755. -                 ; If we're on Windows, there is no setuid, so we make
  756. -                 ; a dummy version. See "Arc 3.1 setuid problem on
  757. -                 ; Windows," http://arclanguage.org/item?id=10625.
  758. -                 (lambda () (lambda (x) 'nil))))
  759. +(define setuid (get-ffi-obj 'setuid #f (_fun _int -> _int)))
  760.  (xdef setuid setuid)
  761.  
  762.  (xdef new-thread thread)
  763. +(xdef kill-thread kill-thread)
  764. +(xdef break-thread break-thread)
  765.  (xdef current-thread current-thread)
  766.  
  767.  (define (wrapnil f) (lambda args (apply f args) 'nil))
  768. @@ -1068,9 +1033,9 @@
  769.  (xdef sleep (wrapnil sleep))
  770.  
  771.  ; Will system "execute" a half-finished string if thread killed
  772. -; in the middle of generating it?
  773. +; in the middle of generating it?  
  774.  
  775. -(xdef system (lambda (s) (tnil (system s))))
  776. +(xdef system (wrapnil system))
  777.  
  778.  (xdef pipe-from (lambda (cmd)
  779.                     (let ((tf (ar-tmpname)))
  780. @@ -1078,7 +1043,7 @@
  781.                       (let ((str (open-input-file tf)))
  782.                         (system (string-append "rm -f " tf))
  783.                         str))))
  784. -
  785. +                  
  786.  (define (ar-tmpname)
  787.    (call-with-input-file "/dev/urandom"
  788.      (lambda (rstr)
  789. @@ -1103,9 +1068,9 @@
  790.                  h)))
  791.  
  792.  ;(xdef table (lambda args
  793. -;               (fill-table (make-hash-table 'equal)
  794. +;               (fill-table (make-hash-table 'equal)
  795.  ;                           (if (pair? args) (ac-denil (car args)) '()))))
  796. -
  797. +                  
  798.  (define (fill-table h pairs)
  799.    (if (eq? pairs '())
  800.        h
  801. @@ -1148,39 +1113,8 @@
  802.  ; top level read-eval-print
  803.  ; tle kept as a way to get a break loop when a scheme err
  804.  
  805. -; To make namespace and module handling more seamless (see
  806. -; lib/ns.arc), we use Racket's 'set! even for undefined variables,
  807. -; rather than using 'namespace-set-variable-value! for all Arc
  808. -; globals. This makes it possible to parameterize the value of
  809. -; 'current-namespace without getting odd behavior, and it makes it
  810. -; possible to assign to imported module variables and use
  811. -; assignment-aware syntax transformers (particularly those made with
  812. -; Racket's 'make-set!-transformer and 'make-rename-transformer).
  813. -;
  814. -; However, by default 'set! is disallowed when the variable is
  815. -; undefined, and we have to use the 'compile-allow-set!-undefined
  816. -; parameter to go against that default. Rather than sprinkling
  817. -; (parameterize ...) forms all over the code and trying to keep them
  818. -; in sync, we put them all in this function, and we use this function
  819. -; instead of 'eval when executing the output of 'ac.
  820. -;
  821. -; In the same spirit, several other uses of 'namespace-variable-value
  822. -; and 'namespace-set-variable-value! have been changed to more direct
  823. -; versions ((set! ...) forms and direct variable references) or less
  824. -; direct versions (uses of full 'arc-eval) depending on how their
  825. -; behavior should change when a module import or syntax obstructs the
  826. -; original meaning of the variable. Some have instead been kept
  827. -; around, but surrounded by (parameterize ...) forms so they're tied
  828. -; the main namespace. Another utility changed in this spirit is
  829. -; 'bound?, which should now be able to see variables which are bound
  830. -; as Racket syntax.
  831. -;
  832. -(define (arc-exec racket-expr)
  833. -  (eval (parameterize ((compile-allow-set!-undefined #t))
  834. -          (compile racket-expr))))
  835. -
  836. -(define (arc-eval expr)
  837. -  (arc-exec (ac expr '())))
  838. +(define (arc-eval expr)
  839. +  (eval (ac expr '())))
  840.  
  841.  (define (tle)
  842.    (display "Arc> ")
  843. @@ -1193,39 +1127,27 @@
  844.  (define last-condition* #f)
  845.  
  846.  (define (tl)
  847. -  (let ((interactive? (terminal-port? (current-input-port))))
  848. -    (when interactive?
  849. -      (display "Use (quit) or ^D to quit, (tl) to return here after an interrupt.\n"))
  850. -    (tl2 interactive?)))
  851. -
  852. -(define (tl2 interactive?)
  853. -  (when interactive? (display "arc> "))
  854. -  (on-err (lambda (c)
  855. +  (display "Use (quit) to quit, (tl) to return here after an interrupt.\n")
  856. +  (tl2))
  857. +
  858. +(define (tl2)
  859. +  (display "arc> ")
  860. +  (on-err (lambda (c)
  861.              (set! last-condition* c)
  862. -            (parameterize ((current-output-port (current-error-port)))
  863. -              (display "Error: ")
  864. -              (write (exn-message c))
  865. -              (newline)
  866. -              (tl2 interactive?)))
  867. +            (display "Error: ")
  868. +            (write (exn-message c))
  869. +            (newline)
  870. +            (tl2))
  871.      (lambda ()
  872.        (let ((expr (read)))
  873. -        (if (eof-object? expr)
  874. -             (begin (when interactive? (newline))
  875. -                    (exit)))
  876.          (if (eqv? expr ':a)
  877.              'done
  878.              (let ((val (arc-eval expr)))
  879. -              (when interactive?
  880. -                (arc-write (ac-denil val))
  881. -                (newline))
  882. -
  883. -              ; The following 'parameterize has been added. See the
  884. -              ; note at 'arc-exec, above.
  885. -              ;
  886. -              (parameterize ((current-namespace main-namespace))
  887. -                (namespace-set-variable-value! '_that val)
  888. -                (namespace-set-variable-value! '_thatexpr expr))
  889. -              (tl2 interactive?)))))))
  890. +              (write (ac-denil val))
  891. +              (namespace-set-variable-value! '_that val)
  892. +              (namespace-set-variable-value! '_thatexpr expr)
  893. +              (newline)
  894. +              (tl2)))))))
  895.  
  896.  (define (aload1 p)
  897.    (let ((x (read p)))
  898. @@ -1260,7 +1182,7 @@
  899.      (if (eof-object? x)
  900.          #t
  901.          (let ((scm (ac x '())))
  902. -          (arc-exec scm)
  903. +          (eval scm)
  904.            (pretty-print scm op)
  905.            (newline op)
  906.            (newline op)
  907. @@ -1274,7 +1196,7 @@
  908.          (delete-file outname))
  909.      (call-with-input-file inname
  910.        (lambda (ip)
  911. -        (call-with-output-file outname
  912. +        (call-with-output-file outname
  913.            (lambda (op)
  914.              (acompile1 ip op)))))))
  915.  
  916. @@ -1283,17 +1205,17 @@
  917.  (xdef macex1 (lambda (e) (ac-macex (ac-denil e) 'once)))
  918.  
  919.  (xdef eval (lambda (e)
  920. -              (arc-eval (ac-denil e))))
  921. +              (eval (ac (ac-denil e) '()))))
  922.  
  923.  ; If an err occurs in an on-err expr, no val is returned and code
  924.  ; after it doesn't get executed.  Not quite what I had in mind.
  925.  
  926.  (define (on-err errfn f)
  927. -  ((call-with-current-continuation
  928. -     (lambda (k)
  929. -       (lambda ()
  930. -         (with-handlers ((exn:fail? (lambda (c)
  931. -                                      (k (lambda () (errfn c))))))
  932. +  ((call-with-current-continuation
  933. +     (lambda (k)
  934. +       (lambda ()
  935. +         (with-handlers ((exn:fail? (lambda (c)
  936. +                                      (k (lambda () (errfn c))))))
  937.                          (f)))))))
  938.  (xdef on-err on-err)
  939.  
  940. @@ -1306,39 +1228,54 @@
  941.  (xdef details (lambda (c)
  942.                   (disp-to-string (exn-message c))))
  943.  
  944. -(xdef scar (lambda (x val)
  945. -              (if (string? x)
  946. +(xdef scar (lambda (x val)
  947. +              (if (string? x)
  948.                    (string-set! x 0 val)
  949.                    (x-set-car! x val))
  950.                val))
  951.  
  952. -(xdef scdr (lambda (x val)
  953. +(xdef scdr (lambda (x val)
  954.                (if (string? x)
  955.                    (err "Can't set cdr of a string" x)
  956.                    (x-set-cdr! x val))
  957.                val))
  958.  
  959. -; waterhouse's code to modify mzscheme-4's immutable pairs.
  960. -; http://arclanguage.org/item?id=13616
  961. -(require racket/unsafe/ops)
  962. +; decide at run-time whether the underlying mzscheme supports
  963. +; set-car! and set-cdr!, since I can't figure out how to do it
  964. +; at compile time.
  965.  
  966. -(define x-set-car!
  967. +(define (x-set-car! p v)
  968.    (let ((fn (namespace-variable-value 'set-car! #t (lambda () #f))))
  969.      (if (procedure? fn)
  970. -        fn
  971. -        (lambda (p x)
  972. -          (if (pair? p)
  973. -              (unsafe-set-mcar! p x)
  974. -              (raise-type-error 'set-car! "pair" p))))))
  975. +        (fn p v)
  976. +        (n-set-car! p v))))
  977.  
  978. -(define x-set-cdr!
  979. +(define (x-set-cdr! p v)
  980.    (let ((fn (namespace-variable-value 'set-cdr! #t (lambda () #f))))
  981.      (if (procedure? fn)
  982. -        fn
  983. -        (lambda (p x)
  984. -          (if (pair? p)
  985. -              (unsafe-set-mcdr! p x)
  986. -              (raise-type-error 'set-cdr! "pair" p))))))
  987. +        (fn p v)
  988. +        (n-set-cdr! p v))))
  989. +
  990. +; Eli's code to modify mzscheme-4's immutable pairs.
  991. +
  992. +;; to avoid a malloc on every call, reuse a single pointer, but make
  993. +;; it thread-local to avoid races
  994. +(define ptr (make-thread-cell #f))
  995. +(define (get-ptr)
  996. +  (or (thread-cell-ref ptr)
  997. +      (let ([p (malloc _scheme 1)]) (thread-cell-set! ptr p) p)))
  998. +
  999. +;; set a pointer to the cons cell, then dereference it as a pointer,
  1000. +;; and bang the new value in the given offset
  1001. +(define (set-ca/dr! offset who p x)
  1002. +  (if (pair? p)
  1003. +    (let ([p* (get-ptr)])
  1004. +      (ptr-set! p* _scheme p)
  1005. +      (ptr-set! (ptr-ref p* _pointer 0) _scheme offset x))
  1006. +    (raise-type-error who "pair" p)))
  1007. +
  1008. +(define (n-set-car! p x) (set-ca/dr! 1 'set-car! p x))
  1009. +(define (n-set-cdr! p x) (set-ca/dr! 2 'set-cdr! p x))
  1010.  
  1011.  ; When and if cdr of a string returned an actual (eq) tail, could
  1012.  ; say (if (string? x) (string-replace! x val 1) ...) in scdr, but
  1013. @@ -1353,7 +1290,7 @@
  1014.  
  1015.  ; Later may want to have multiple indices.
  1016.  
  1017. -(xdef sref
  1018. +(xdef sref
  1019.    (lambda (com val ind)
  1020.      (cond ((hash-table? com)  (if (eqv? val 'nil)
  1021.                                    (hash-table-remove! com ind)
  1022. @@ -1366,11 +1303,12 @@
  1023.  (define (nth-set! lst n val)
  1024.    (x-set-car! (list-tail lst n) val))
  1025.  
  1026. +; rewrite to pass a (true) gensym instead of #f in case var bound to #f
  1027. +
  1028.  (define (bound? arcname)
  1029. -  (with-handlers ((exn:fail:syntax? (lambda (e) #t))
  1030. -                  (exn:fail:contract:variable? (lambda (e) #f)))
  1031. -    (namespace-variable-value (ac-global-name arcname))
  1032. -    #t))
  1033. +  (namespace-variable-value (ac-global-name arcname)
  1034. +                            #t
  1035. +                            (lambda () #f)))
  1036.  
  1037.  (xdef bound (lambda (x) (tnil (bound? x))))
  1038.  
  1039. @@ -1390,7 +1328,7 @@
  1040.  
  1041.  (print-hash-table #t)
  1042.  
  1043. -(xdef client-ip (lambda (port)
  1044. +(xdef client-ip (lambda (port)
  1045.                     (let-values (((x y) (tcp-addresses port)))
  1046.                       y)))
  1047.  
  1048. @@ -1399,30 +1337,29 @@
  1049.  ; nest within a thread; the thread-cell keeps track of
  1050.  ; whether this thread already holds the lock.
  1051.  
  1052. -(define ar-atomic-sema (make-semaphore 1))
  1053. -(define ar-atomic-cell (make-thread-cell #f))
  1054. +(define ar-the-sema (make-semaphore 1))
  1055. +
  1056. +(define ar-sema-cell (make-thread-cell #f))
  1057. +
  1058.  (xdef atomic-invoke (lambda (f)
  1059. -                       (if (thread-cell-ref ar-atomic-cell)
  1060. +                       (if (thread-cell-ref ar-sema-cell)
  1061.                             (ar-apply f '())
  1062.                             (begin
  1063. -                             (thread-cell-set! ar-atomic-cell #t)
  1064. -                             (protect
  1065. -                              (lambda ()
  1066. -                                (call-with-semaphore
  1067. -                                 ar-atomic-sema
  1068. -                                 (lambda () (ar-apply f '()))))
  1069. -                              (lambda ()
  1070. -                                (thread-cell-set! ar-atomic-cell #f)))))))
  1071. +                             (thread-cell-set! ar-sema-cell #t)
  1072. +                            (protect
  1073. +                             (lambda ()
  1074. +                               (call-with-semaphore
  1075. +                                ar-the-sema
  1076. +                                (lambda () (ar-apply f '()))))
  1077. +                             (lambda ()
  1078. +                               (thread-cell-set! ar-sema-cell #f)))))))
  1079.  
  1080.  (xdef dead (lambda (x) (tnil (thread-dead? x))))
  1081.  
  1082.  ; Added because Mzscheme buffers output.  Not a permanent part of Arc.
  1083.  ; Only need to use when declare explicit-flush optimization.
  1084.  
  1085. -(xdef flushout (lambda args (flush-output (if (pair? args)
  1086. -                                              (car args)
  1087. -                                              (current-output-port)))
  1088. -                            't))
  1089. +(xdef flushout (lambda () (flush-output) 't))
  1090.  
  1091.  (xdef ssyntax (lambda (x) (tnil (ssyntax? x))))
  1092.  
  1093. @@ -1480,18 +1417,19 @@
  1094.  
  1095.  (xdef memory current-memory-use)
  1096.  
  1097. -(define ar-declarations (make-hash-table))
  1098. -
  1099. -(define (ar-bflag key)
  1100. -  (not (ar-false? (hash-table-get ar-declarations key 'nil))))
  1101. -
  1102. -(xdef declarations* ar-declarations)
  1103. +(xdef declare (lambda (key val)
  1104. +                (let ((flag (not (ar-false? val))))
  1105. +                  (case key
  1106. +                    ((atstrings)      (set! atstrings      flag))
  1107. +                    ((direct-calls)   (set! direct-calls   flag))
  1108. +                    ((explicit-flush) (set! explicit-flush flag)))
  1109. +                  val)))
  1110.  
  1111.  (putenv "TZ" ":GMT")
  1112.  
  1113.  (define (gmt-date sec) (seconds->date sec))
  1114.  
  1115. -(xdef timedate
  1116. +(xdef timedate
  1117.    (lambda args
  1118.      (let ((d (gmt-date (if (pair? args) (car args) (current-seconds)))))
  1119.        (ac-niltree (list (date-second d)
  1120. @@ -1501,10 +1439,6 @@
  1121.                          (date-month d)
  1122.                          (date-year d))))))
  1123.  
  1124. -(xdef utf-8-bytes
  1125. -  (lambda (str)
  1126. -    (bytes->list (string->bytes/utf-8 str))))
  1127. -
  1128.  (xdef sin sin)
  1129.  (xdef cos cos)
  1130.  (xdef tan tan)
  1131. @@ -1513,12 +1447,6 @@
  1132.  (xdef atan atan)
  1133.  (xdef log log)
  1134.  
  1135. -(xdef lor bitwise-ior)
  1136. -(xdef land bitwise-and)
  1137. -(xdef lxor bitwise-xor)
  1138. -(xdef lnot bitwise-not)
  1139. -(xdef shl arithmetic-shift)
  1140. -
  1141.  (define (codestring s)
  1142.    (let ((i (atpos s 0)))
  1143.      (if i
  1144. @@ -1534,27 +1462,28 @@
  1145.  ; First unescaped @ in s, if any.  Escape by doubling.
  1146.  
  1147.  (define (atpos s i)
  1148. -  (cond ((eqv? i (string-length s))
  1149. +  (cond ((eqv? i (string-length s))
  1150.           #f)
  1151.  (xdef cos cos)
  1152.  (xdef tan tan)
  1153. @@ -1513,12 +1447,6 @@
  1154.  (xdef atan atan)
  1155.  (xdef log log)
  1156.  
  1157. -(xdef lor bitwise-ior)
  1158. -(xdef land bitwise-and)
  1159. -(xdef lxor bitwise-xor)
  1160. -(xdef lnot bitwise-not)
  1161. -(xdef shl arithmetic-shift)
  1162. -
  1163.  (define (codestring s)
  1164.    (let ((i (atpos s 0)))
  1165.      (if i
  1166. @@ -1534,27 +1462,28 @@
  1167.  ; First unescaped @ in s, if any.  Escape by doubling.
  1168.  
  1169.  (define (atpos s i)
  1170. -  (cond ((eqv? i (string-length s))
  1171. +  (cond ((eqv? i (string-length s))
  1172.           #f)
  1173.          ((eqv? (string-ref s i) #\@)
  1174.           (if (and (< (+ i 1) (string-length s))
  1175.                    (not (eqv? (string-ref s (+ i 1)) #\@)))
  1176.               i
  1177.               (atpos s (+ i 2))))
  1178. -        (#t
  1179. +        (#t                        
  1180.           (atpos s (+ i 1)))))
  1181.  
  1182.  (define (unescape-ats s)
  1183.    (list->string (letrec ((unesc (lambda (cs)
  1184. -                                  (cond
  1185. -                                    ((null? cs)
  1186. +                                  (cond
  1187. +                                    ((null? cs)
  1188.                                       '())
  1189. -                                    ((and (eqv? (car cs) #\@)
  1190. +                                    ((and (eqv? (car cs) #\@)
  1191.                                            (not (null? (cdr cs)))
  1192.                                            (eqv? (cadr cs) #\@))
  1193.                                       (unesc (cdr cs)))
  1194.                                      (#t
  1195.                                       (cons (car cs) (unesc (cdr cs))))))))
  1196.                    (unesc (string->list s)))))
  1197. -
  1198. +  
  1199.  )
  1200. +
Advertisement
Add Comment
Please, Sign In to add comment
Advertisement
Public Pastes
Advertisement
We use cookies for various purposes including analytics. By continuing to use Pastebin, you agree to our use of cookies as described in the Cookies Policy.  OK, I Understand
Not a member of Pastebin yet?
Sign Up, it unlocks many cool features!