| 44 |
(ac (cons 'string (map (lambda (x) |
= |
44 |
(ac (cons 'string (map (lambda (x) |
| 45 |
(if (string? x) |
|
45 |
(if (string? x) |
| 46 |
(unescape-ats x) |
|
46 |
(unescape-ats x) |
| 47 |
x)) |
|
47 |
x)) |
| 48 |
(codestring s))) |
|
48 |
(codestring s))) |
| 49 |
env) |
|
49 |
env) |
| 50 |
(unescape-ats s)) |
<> |
50 |
(list 'string-copy (unescape-ats s))) |
| 51 |
(string-copy s))) ; avoid immutable strings |
|
51 |
(list 'string-copy s))) ; avoid immutable strings |
| 52 |
|
= |
52 |
|
| 53 |
(define (literal? x) |
|
53 |
(define (literal? x) |
| 54 |
(or (boolean? x) |
|
54 |
(or (boolean? x) |
| 55 |
(char? x) |
|
55 |
(char? x) |
| 56 |
(string? x) |
|
56 |
(string? x) |
| 57 |
(number? x) |
|
57 |
(number? x) |
| |
| 1017 |
out |
= |
1017 |
out |
| 1018 |
(let-values (((us them) (tcp-addresses out))) |
|
1018 |
(let-values (((us them) (tcp-addresses out))) |
| 1019 |
them)))))))) |
|
1019 |
them)))))))) |
| 1020 |
|
|
1020 |
|
| 1021 |
; allow Arc to give up root privileges after it |
|
1021 |
; allow Arc to give up root privileges after it |
| 1022 |
; calls open-socket. thanks, Eli! |
|
1022 |
; calls open-socket. thanks, Eli! |
| 1023 |
(define setuid (get-ffi-obj 'setuid #f (_fun _int -> _int))) |
<> |
1023 |
(define setuid (get-ffi-obj 'setuid #f (_fun _int -> _int) |
| |
|
|
1024 |
; dummy version for Windows: http://arclanguage.org/item?id=10625. |
| |
|
|
1025 |
(lambda () (lambda (x) 'nil)))) |
| 1024 |
(xdef setuid setuid) |
= |
1026 |
(xdef setuid setuid) |
| 1025 |
|
|
1027 |
|
| 1026 |
(xdef new-thread thread) |
|
1028 |
(xdef new-thread thread) |
| 1027 |
(xdef kill-thread kill-thread) |
|
1029 |
(xdef kill-thread kill-thread) |
| 1028 |
(xdef break-thread break-thread) |
|
1030 |
(xdef break-thread break-thread) |
| 1029 |
(xdef current-thread current-thread) |
|
1031 |
(xdef current-thread current-thread) |
| |
| 1137 |
(display "Error: ") |
= |
1139 |
(display "Error: ") |
| 1138 |
(write (exn-message c)) |
|
1140 |
(write (exn-message c)) |
| 1139 |
(newline) |
|
1141 |
(newline) |
| 1140 |
(tl2)) |
|
1142 |
(tl2)) |
| 1141 |
(lambda () |
|
1143 |
(lambda () |
| 1142 |
(let ((expr (read))) |
|
1144 |
(let ((expr (read))) |
| 1143 |
(if (eqv? expr ':a) |
<> |
1145 |
(if (or (eof-object? expr) (eqv? expr ':a)) |
| 1144 |
'done |
= |
1146 |
'done |
| 1145 |
(let ((val (arc-eval expr))) |
|
1147 |
(let ((val (arc-eval expr))) |
| 1146 |
(write (ac-denil val)) |
|
1148 |
(write (ac-denil val)) |
| 1147 |
(namespace-set-variable-value! '_that val) |
|
1149 |
(namespace-set-variable-value! '_that val) |
| 1148 |
(namespace-set-variable-value! '_thatexpr expr) |
|
1150 |
(namespace-set-variable-value! '_thatexpr expr) |
| 1149 |
(newline) |
|
1151 |
(newline) |
| |
| 1237 |
(xdef scdr (lambda (x val) |
= |
1239 |
(xdef scdr (lambda (x val) |
| 1238 |
(if (string? x) |
|
1240 |
(if (string? x) |
| 1239 |
(err "Can't set cdr of a string" x) |
|
1241 |
(err "Can't set cdr of a string" x) |
| 1240 |
(x-set-cdr! x val)) |
|
1242 |
(x-set-cdr! x val)) |
| 1241 |
val)) |
|
1243 |
val)) |
| 1242 |
|
|
1244 |
|
| 1243 |
; decide at run-time whether the underlying mzscheme supports |
<> |
|
|
| 1244 |
; set-car! and set-cdr!, since I can't figure out how to do it |
|
1245 |
; waterhouse's code to modify Racket's immutable pairs. |
| 1245 |
; at compile time. |
|
1246 |
; http://arclanguage.org/item?id=13616 |
| |
|
|
1247 |
(require racket/unsafe/ops) |
| 1246 |
|
= |
1248 |
|
| 1247 |
(define (x-set-car! p v) |
<> |
1249 |
(define x-set-car! |
| 1248 |
(let ((fn (namespace-variable-value 'set-car! #t (lambda () #f)))) |
= |
1250 |
(let ((fn (namespace-variable-value 'set-car! #t (lambda () #f)))) |
| 1249 |
(if (procedure? fn) |
|
1251 |
(if (procedure? fn) |
| 1250 |
(fn p v) |
<> |
1252 |
fn |
| |
|
|
1253 |
(lambda (p x) |
| |
|
|
1254 |
(if (pair? p) |
| 1251 |
(n-set-car! p v)))) |
|
1255 |
(unsafe-set-mcar! p x) |
| |
|
|
1256 |
(raise-type-error 'set-car! "pair" p)))))) |
| 1252 |
|
= |
1257 |
|
| 1253 |
(define (x-set-cdr! p v) |
<> |
1258 |
(define x-set-cdr! |
| 1254 |
(let ((fn (namespace-variable-value 'set-cdr! #t (lambda () #f)))) |
= |
1259 |
(let ((fn (namespace-variable-value 'set-cdr! #t (lambda () #f)))) |
| 1255 |
(if (procedure? fn) |
|
1260 |
(if (procedure? fn) |
| 1256 |
(fn p v) |
<> |
1261 |
fn |
| 1257 |
(n-set-cdr! p v)))) |
|
|
|
| 1258 |
|
|
1262 |
(lambda (p x) |
| 1259 |
; Eli's code to modify mzscheme-4's immutable pairs. |
|
|
|
| 1260 |
|
= |
|
|
| 1261 |
;; to avoid a malloc on every call, reuse a single pointer, but make |
+- |
|
|
| 1262 |
;; it thread-local to avoid races |
|
|
|
| 1263 |
(define ptr (make-thread-cell #f)) |
|
|
|
| 1264 |
(define (get-ptr) |
|
|
|
| 1265 |
(or (thread-cell-ref ptr) |
|
|
|
| 1266 |
(let ([p (malloc _scheme 1)]) (thread-cell-set! ptr p) p))) |
|
|
|
| 1267 |
|
= |
|
|
| 1268 |
;; set a pointer to the cons cell, then dereference it as a pointer, |
+- |
|
|
| 1269 |
;; and bang the new value in the given offset |
|
|
|
| 1270 |
(define (set-ca/dr! offset who p x) |
|
|
|
| 1271 |
(if (pair? p) |
= |
1263 |
(if (pair? p) |
| 1272 |
(let ([p* (get-ptr)]) |
<> |
|
|
| 1273 |
(ptr-set! p* _scheme p) |
|
1264 |
(unsafe-set-mcdr! p x) |
| 1274 |
(ptr-set! (ptr-ref p* _pointer 0) _scheme offset x)) |
|
|
|
| 1275 |
(raise-type-error who "pair" p))) |
|
1265 |
(raise-type-error 'set-cdr! "pair" p)))))) |
| 1276 |
|
= |
|
|
| 1277 |
(define (n-set-car! p x) (set-ca/dr! 1 'set-car! p x)) |
+- |
|
|
| 1278 |
(define (n-set-cdr! p x) (set-ca/dr! 2 'set-cdr! p x)) |
|
|
|
| 1279 |
|
= |
1266 |
|
| 1280 |
; When and if cdr of a string returned an actual (eq) tail, could |
|
1267 |
; When and if cdr of a string returned an actual (eq) tail, could |
| 1281 |
; say (if (string? x) (string-replace! x val 1) ...) in scdr, but |
|
1268 |
; say (if (string? x) (string-replace! x val 1) ...) in scdr, but |
| 1282 |
; for now would be misleading to allow this, because fails for cddr. |
|
1269 |
; for now would be misleading to allow this, because fails for cddr. |
| 1283 |
|
|
1270 |
|
| 1284 |
(define (string-replace! str val index) |
|
1271 |
(define (string-replace! str val index) |