1;; -*- scheme -*- 2(library (core) 3 (export :all) 4 (import :none) 5 (decl-code 6 (.define "LIBSAGITTARIUS_BODY") 7 (.include <sagittarius/private.h> 8 <sagittarius/private/instruction.h> 9 <sagittarius/private/builtin-symbols.h> 10 ;; need this... 11 "shortnames.incl" 12 "gc-incl.inc")) 13 14 (define-cise-stmt assertion-violation 15 ((_ who msg) 16 `(begin 17 (Sg_AssertionViolation ,who (SG_MAKE_STRING ,msg) '()))) 18 ((_ who msg irritants) 19 `(begin 20 (Sg_AssertionViolation ,who (SG_MAKE_STRING ,msg) ,irritants) 21 ))) 22 23 (define-cise-stmt wrong-type-of-argument-violation 24 ((_ who msg got) 25 `(begin 26 (Sg_WrongTypeOfArgumentViolation ,who (SG_MAKE_STRING ,msg) ,got '()))) 27 ((_ who msg got irritants) 28 `(begin 29 (Sg_WrongTypeOfArgumentViolation ,who (SG_MAKE_STRING ,msg) ,got ,irritants)))) 30 31 (define-cise-stmt throw-i/o-error 32 ((_ type who msg file) 33 `(throw-i/o-error ,type ,who ,msg ,file SG_UNDEF)) 34 ((_ type who msg file ret) 35 `(begin 36 (Sg_IOError ,type ,who (SG_MAKE_STRING ,msg) ,file SG_UNDEF) 37 (return ,ret)))) 38 39 ;; x=? macro 40 (define-cise-stmt x=? 41 ((_ checker compare name first second rest) 42 `(begin 43 (,checker ,name ,first) 44 (,checker ,name ,second) 45 (cond ((SG_NULLP ,rest) 46 (result (,compare ,first ,second))) 47 ((not (,compare ,first ,second)) 48 (result FALSE)) 49 (else 50 (let ((prev ,second)) 51 (dolist (p ,rest) 52 (,checker ,name p) 53 (unless (,compare prev p) 54 (return #f)) 55 (set! prev p)) 56 (result TRUE))))))) 57 58 ;; 11.1 base type 59 (define-c-proc boolean? (o) ::<boolean> :constant SG_BOOLP) 60 (define-c-proc pair? (o) ::<boolean> :constant (inline PAIRP) SG_PAIRP) 61 (define-c-proc symbol? (o) ::<boolean> :constant (inline SYMBOLP) SG_SYMBOLP) 62 (define-c-proc number? (o) ::<boolean> :constant SG_NUMBERP) 63 (define-c-proc char? (o) ::<boolean> :constant SG_CHARP) 64 (define-c-proc string? (o) ::<boolean> :constant SG_STRINGP) 65 (define-c-proc vector? (o) ::<boolean> :constant (inline VECTORP) SG_VECTORP) 66 (define-c-proc procedure? (o) ::<boolean> :constant SG_PROCEDUREP) 67 (define-c-proc null? (o) ::<boolean> :constant (inline NULLP) SG_NULLP) 68 69 ;; 11.5 equivalence predicates 70 ;; defined in compare.c 71 ;;(define-c-proc eq? (a b) ::<boolean> :constant (inline EQ) SG_EQ) 72 ;;(define-c-proc eqv? (a b) ::<boolean> :constant (inline EQV) Sg_EqvP) 73 ;;(define-c-proc equal? (a b) ::<boolean> :constant Sg_EqualP) 74 75 ;; 11.7.4.1 numerical type predicates 76 (define-c-proc complex? (o) ::<boolean> :constant SG_NUMBERP) 77 (define-c-proc real? (o) ::<boolean> :constant SG_REALP) 78 (define-c-proc rational? (o) ::<boolean> :constant Sg_RationalP) 79 (define-c-proc integer? (o) ::<boolean> :constant Sg_IntegerP) 80 (define-c-proc real-valued? (o) ::<boolean> :constant Sg_RealValuedP) 81 (define-c-proc rational-valued? (o) ::<boolean> :constant Sg_RationalValuedP) 82 (define-c-proc integer-valued? (o) ::<boolean> :constant Sg_IntegerValuedP) 83 (define-c-proc exact? (o) ::<boolean> :constant Sg_ExactP) 84 (define-c-proc inexact? (o) ::<boolean> :constant Sg_InexactP) 85 86 ;; 11.7.4.2 generic conversions 87 (define-c-proc inexact (z::<number>) :constant Sg_Inexact) 88 (define-c-proc exact (z::<number>) :constant Sg_Exact) 89 90 ;; 11.7.4.3 arithmetic operations 91 (define-cise-stmt check-real 92 ((_ name o) 93 `(unless (SG_REALP ,o) 94 (wrong-type-of-argument-violation ',name "real number" ,o)))) 95 96 (define-cise-stmt numcmp 97 ((_ op compar) 98 `(loop (cond ((not (,op (,compar arg0 arg1) 0)) (break)) 99 ((SG_NULLP rest) (result TRUE) (break)) 100 (else (set! arg0 arg1) 101 (set! arg1 (SG_CAR rest)) 102 (set! rest (SG_CDR rest))))))) 103 ;; = < > <= >= 104 (define-c-proc = (arg0 arg1 :rest rest) ::<boolean> :constant 105 (result FALSE) 106 (loop (cond ((not (Sg_NumEq arg0 arg1)) (break)) 107 ((SG_NULLP rest) (result TRUE) (break)) 108 (else (set! arg0 arg1) 109 (set! arg1 (SG_CAR rest)) 110 (set! rest (SG_CDR rest)))))) 111 (define-c-proc < (arg0 arg1 :rest rest) ::<boolean> :constant 112 (result FALSE) 113 (numcmp < Sg_NumCmp)) 114 (define-c-proc <= (arg0 arg1 :rest rest) ::<boolean> :constant 115 (result FALSE) 116 (numcmp <= Sg_NumCmp)) 117 (define-c-proc > (arg0 arg1 :rest rest) ::<boolean> :constant 118 (result FALSE) 119 (numcmp > Sg_NumCmp)) 120 (define-c-proc >= (arg0 arg1 :rest rest) ::<boolean> :constant 121 (result FALSE) 122 (numcmp >= Sg_NumCmp)) 123 124 (define-c-proc zero? (n::<number>) ::<boolean> :constant Sg_ZeroP) 125 (define-c-proc positive? (x::<number>) ::<boolean> :constant Sg_PositiveP) 126 (define-c-proc negative? (x::<number>) ::<boolean> :constant Sg_NegativeP) 127 (define-c-proc odd? (x::<number>) ::<boolean> :constant Sg_OddP) 128 (define-c-proc even? (x::<number>) ::<boolean> :constant 129 (result (not (Sg_OddP x)))) 130 (define-c-proc finite? (x::<number>) ::<boolean> Sg_FiniteP) 131 (define-c-proc infinite? (x::<number>) ::<boolean> Sg_InfiniteP) 132 (define-c-proc nan? (x::<number>) ::<boolean> Sg_NanP) 133 134 (define-c-proc max (arg0 :rest rest) :constant 135 (Sg_MinMax arg0 rest NULL (& SG_RESULT))) 136 (define-c-proc min (arg0 :rest rest) :constant 137 (Sg_MinMax arg0 rest (& SG_RESULT) NULL)) 138 139 ;; arithmetic 140 (define-cise-stmt check-number 141 ((_ name v) 142 `(unless (SG_NUMBERP ,v) 143 (wrong-type-of-argument-violation ',name "number" ,v)))) 144 145 ;; are these arithmetic operation constant? 146 (define-c-proc + (:rest rest) :constant 147 (cond ((not (SG_PAIRP rest)) (result (SG_MAKE_INT 0))) 148 ((not (SG_NUMBERP (SG_CAR rest))) 149 (wrong-type-of-argument-violation '+ "number" (SG_CAR rest) rest) 150 (result SG_UNDEF)) ; dummy 151 (else 152 (let ((r (SG_CAR rest))) 153 (dolist (v (SG_CDR rest)) 154 (check-number + v) 155 (set! r (Sg_Add r v))) 156 (result r))))) 157 158 (define-c-proc * (:rest rest) :constant 159 (cond ((not (SG_PAIRP rest)) (result (SG_MAKE_INT 1))) 160 ((not (SG_NUMBERP (SG_CAR rest))) 161 (wrong-type-of-argument-violation '+ "number" (SG_CAR rest) rest) 162 (result SG_UNDEF)) ; dummy 163 (else 164 (let ((r (SG_CAR rest))) 165 (dolist (v (SG_CDR rest)) 166 (check-number * v) 167 (set! r (Sg_Mul r v))) 168 (result r))))) 169 170 (define-c-proc - (arg1::<number> :rest rest) :constant 171 (if (SG_NULLP rest) 172 (result (Sg_Negate arg1)) 173 (begin 174 (dolist (v rest) 175 (check-number - v) 176 (set! arg1 (Sg_Sub arg1 v))) 177 (result arg1)))) 178 179 (define-c-proc / (arg1::<number> :rest rest) :constant 180 (if (SG_NULLP rest) 181 (result (Sg_Inverse arg1)) 182 (let ((exact::int (Sg_ExactP arg1))) 183 (dolist (v rest) 184 (check-number / v) 185 ;; if inexact numbers have already appeared, 186 ;; we can skip checking 187 (when exact (set! exact (Sg_ExactP v))) 188 (when (and exact (Sg_ZeroP v)) 189 (assertion-violation '/ "undefined for 0" (Sg_Cons arg1 rest))) 190 (set! arg1 (Sg_Div arg1 v))) 191 (result arg1)))) 192 193 ;; base arithmetic 194 (define-c-proc abs (x::<number>) :constant Sg_Abs) 195 (define-c-proc numerator (x::<number>) :constant Sg_Numerator) 196 (define-c-proc denominator (x::<number>) :constant Sg_Denominator) 197 198 (define-cise-stmt check-real-valued 199 ((_ name n) 200 `(unless (Sg_RealValuedP ,n) 201 (wrong-type-of-argument-violation ',name "real number" ,n)))) 202 203 (define-c-proc floor (x::<number>) :constant 204 (check-real-valued floor x) 205 (result (Sg_Round x SG_ROUND_FLOOR))) 206 207 (define-c-proc ceiling (x::<number>) :constant 208 (check-real-valued ceiling x) 209 (result (Sg_Round x SG_ROUND_CEIL))) 210 211 (define-c-proc truncate (x::<number>) :constant 212 (check-real-valued truncate x) 213 (result (Sg_Round x SG_ROUND_TRUNC))) 214 215 (define-c-proc round (x::<number>) :constant 216 (check-real-valued round x) 217 (result (Sg_Round x SG_ROUND_ROUND))) 218 219 (define-cise-stmt check-finite 220 ((_ name n) 221 `(unless (Sg_FiniteP ,n) 222 (wrong-type-of-argument-violation ',name "finite" ,n)))) 223 224 (define-cise-stmt check-not-nan 225 ((_ name n) 226 `(when (Sg_NanP ,n) 227 (wrong-type-of-argument-violation ',name "non nan" ,n)))) 228 229 (define-cise-stmt check-not-zero 230 ((_ name n) 231 `(when (Sg_ZeroP ,n) 232 (wrong-type-of-argument-violation ',name "not zero" ,n)))) 233 234 (define-cise-stmt check-integer-arith-argument 235 ((_ name x y) 236 `(begin 237 (check-finite ,name ,x) 238 (check-not-nan ,name ,x) 239 (check-not-zero ,name ,y)))) 240 241 (define-c-proc div (x::<number> y::<number>) :constant 242 (check-integer-arith-argument div x y) 243 (result (Sg_IntegerDiv x y))) 244 245 (define-c-proc mod (x::<number> y::<number>) :constant 246 (check-integer-arith-argument mod x y) 247 (result (Sg_IntegerMod x y))) 248 249 (define-c-proc div0 (x::<number> y::<number>) :constant 250 (check-integer-arith-argument div0 x y) 251 (result (Sg_IntegerDiv0 x y))) 252 253 (define-c-proc mod0 (x::<number> y::<number>) :constant 254 (check-integer-arith-argument mod0 x y) 255 (result (Sg_IntegerMod0 x y))) 256 257 ;; takes 2. r6rs implementation is in scmlib.scm 258 (define-c-proc %gcd (x::<number> y::<number>) :constant Sg_Gcd) 259 260 (define-c-proc exp (x::<number>) :constant Sg_Exp) 261 (define-c-proc expt (x::<number> y::<number>) :constant Sg_Expt) 262 263 (define-c-proc log (x::<number> :optional base::<number>) :constant 264 (if (SG_UNBOUNDP base) 265 (if (== x (SG_MAKE_INT 0)) 266 (assertion-violation 'log "undefined for 0" x) 267 (result (Sg_Log x))) 268 (result (Sg_Div (Sg_Log x) (Sg_Log base))))) 269 270 (define-c-proc make-rectangular (a::<number> b::<number>) :constant 271 (unless (SG_REALP a) 272 (wrong-type-of-argument-violation 'make-rectangular "real number required" 273 a (SG_LIST2 a b))) 274 (unless (SG_REALP b) 275 (wrong-type-of-argument-violation 'make-rectangular "real number required" 276 b (SG_LIST2 a b))) 277 (result (Sg_MakeComplex a b))) 278 279 (define-c-proc make-polar (r::<number> t::<number>) :constant 280 (unless (SG_REALP r) 281 (wrong-type-of-argument-violation 'make-polar "real number required" 282 r (SG_LIST2 r t))) 283 (unless (SG_REALP t) 284 (wrong-type-of-argument-violation 'make-polar "real number required" 285 t (SG_LIST2 r t))) 286 (result (Sg_MakeComplexPolar r t))) 287 288 (define-c-proc real-part (r::<number>) :constant 289 (cond ((SG_COMPLEXP r) 290 (result (-> (SG_COMPLEX r) real))) 291 ((SG_REALP r) (result r)) 292 (else 293 ;; never happen 294 (wrong-type-of-argument-violation 'real-part "number required" r)))) 295 296 (define-c-proc imag-part (r::<number>) :constant 297 (cond ((SG_COMPLEXP r) 298 (result (-> (SG_COMPLEX r) imag))) 299 ((SG_REALP r) 300 (result (SG_MAKE_INT 0))) 301 (else 302 (wrong-type-of-argument-violation 'imag-part "number required" r)))) 303 304 (define-c-proc magnitude (n::<number>) :constant Sg_Magnitude) 305 (define-c-proc angle (n::<number>) :constant Sg_Angle) 306 307 (define-c-proc sin (n::<number>) :constant Sg_Sin) 308 (define-c-proc cos (n::<number>) :constant Sg_Cos) 309 (define-c-proc tan (n::<number>) :constant Sg_Tan) 310 (define-c-proc asin (n::<number>) :constant Sg_Asin) 311 (define-c-proc acos (n::<number>) :constant Sg_Acos) 312 313 (define-c-proc atan (n::<number> :optional n2::<number>) :constant 314 (cond ((SG_UNBOUNDP n2) (result (Sg_Atan n))) 315 (else 316 (check-real-valued atan n) 317 (check-real-valued atan n2) 318 (result (Sg_Atan2 n n2))))) 319 320 (define-c-proc sqrt (n::<number>) :constant Sg_Sqrt) 321 (define-c-proc exact-integer-sqrt (n::<number>) :constant 322 (when (or (Sg_NegativeP n) (not (SG_EXACT_INTP n))) 323 (wrong-type-of-argument-violation 'exact-integer-sqrt 324 "non-negative exact integer required" 325 n)) 326 (result (Sg_ExactIntegerSqrt n))) 327 328 (define-c-proc rationalize (x::<number> e::<number>) :constant 329 (check-real rationalize x) 330 (check-real rationalize e) 331 (result (Sg_Rationalize x e))) 332 333 ;; r5rs compatible 334 (define-c-proc quotient (n1::<number> n2::<number>) :constant 335 (when (SG_EQ n2 (SG_MAKE_INT 0)) 336 (assertion-violation 'quotient "attempt to calculate a quotient by zero" 337 (SG_LIST2 n1 n2))) 338 (result (Sg_Quotient n1 n2 NULL))) 339 340 (define-c-proc remainder (n1::<number> n2::<number>) :constant 341 (result (Sg_Modulo n1 n2 TRUE))) 342 343 (define-c-proc modulo (n1::<number> n2::<number>) :constant 344 (result (Sg_Modulo n1 n2 FALSE))) 345 346 (define-c-proc integer-length (n::<number>) ::<fixnum> :constant 347 Sg_IntegerLength) 348 349 ;; 11.7.4.4 numerical input and output 350 (define-c-proc number->string (z::<number> 351 :optional (radix::<fixnum> 10) 352 precision) :constant 353 ;; ignore precision 354 (result (Sg_NumberToString z (cast int radix) FALSE))) 355 356 (define-c-proc string->number (s::<string> :optional (radix::<fixnum> 10)) 357 :constant 358 (result (Sg_StringToNumber s (cast int radix) FALSE))) 359 360 ;; 11.8 booleans 361 (define-c-proc not (arg0) ::<boolean> :constant (inline NOT) SG_FALSEP) 362 363 (define-cise-stmt check-boolean 364 ((_ name b) 365 `(unless (SG_BOOLP ,b) 366 (wrong-type-of-argument-violation ',name "boolean" ,b)))) 367 368 (define-c-proc boolean=? (b1 b2 :rest rest) ::<boolean> :constant 369 (x=? check-boolean SG_EQ boolean=? b1 b2 rest)) 370 371 ;; 11.9 pairs and lists 372 (define-c-proc cons (o1 o2) :no-side-effect (inline CONS) Sg_Cons) 373 (define-c-proc car (o::<pair>) :constant 374 (inline CAR) (setter set-car!) SG_CAR) 375 376 (define-c-proc cdr (o::<pair>) :constant 377 (inline CDR) (setter set-cdr!) SG_CDR) 378 379 "#define CXR_SETTER(PRE, pre, tail) \ 380 SgObject cell = Sg_C##tail##r(obj); \ 381 if (!SG_PAIRP(cell)) \ 382 Sg_Error(UC(\"can't set c\" #pre #tail \"r of %S\"), obj); \ 383 SG_SET_C##PRE##R(cell, value);" 384 385 (define-c-proc caar (o::<pair>) :constant (inline CAAR) 386 (setter (obj value) ::<void> (CXR_SETTER A a a)) Sg_Caar) 387 (define-c-proc cadr (o::<pair>) :constant (inline CADR) 388 (setter (obj value) ::<void> (CXR_SETTER A a d)) Sg_Cadr) 389 (define-c-proc cdar (o::<pair>) :constant (inline CDAR) 390 (setter (obj value) ::<void> (CXR_SETTER D d a)) Sg_Cdar) 391 (define-c-proc cddr (o::<pair>) :constant (inline CDDR) 392 (setter (obj value) ::<void> (CXR_SETTER D d d)) Sg_Cddr) 393 394 ;; moved from (core base) 395 ;; Why did I do this... 396 "#define CXXR_SETTER(PRE, pre, tail) \ 397 SgObject cell = Sg_C##pre##r(Sg_C##tail##r(obj)); \ 398 if (!SG_PAIRP(cell)) \ 399 Sg_Error(UC(\"can't set c\" #pre #tail \"r of %S\"), obj); \ 400 SG_SET_C##PRE##R(cell, value);" 401 402 (define-c-proc caaar (o) :constant 403 (setter (obj value) ::<void> (CXXR_SETTER A a a)) 404 (result (Sg_Car (Sg_Caar o)))) 405 (define-c-proc caadr (o) :constant 406 (setter (obj value) ::<void> (CXXR_SETTER A a d)) 407 (result (Sg_Car (Sg_Cadr o)))) 408 (define-c-proc cadar (o) :constant 409 (setter (obj value) ::<void> (CXXR_SETTER A d a)) 410 (result (Sg_Car (Sg_Cdar o)))) 411 (define-c-proc caddr (o) :constant 412 (setter (obj value) ::<void> (CXXR_SETTER A d d)) 413 (result (Sg_Car (Sg_Cddr o)))) 414 (define-c-proc cdaar (o) :constant 415 (setter (obj value) ::<void> (CXXR_SETTER D a a)) 416 (result (Sg_Cdr (Sg_Caar o)))) 417 (define-c-proc cdadr (o) :constant 418 (setter (obj value) ::<void> (CXXR_SETTER D a d)) 419 (result (Sg_Cdr (Sg_Cadr o)))) 420 (define-c-proc cddar (o) :constant 421 (setter (obj value) ::<void> (CXXR_SETTER D d a)) 422 (result (Sg_Cdr (Sg_Cdar o)))) 423 (define-c-proc cdddr (o) :constant 424 (setter (obj value) ::<void> (CXXR_SETTER D d d)) 425 (result (Sg_Cdr (Sg_Cddr o)))) 426 (define-c-proc caaaar (o) :constant 427 (setter (obj value) ::<void> (CXXR_SETTER A a aa)) 428 (result (Sg_Caar (Sg_Caar o)))) 429 (define-c-proc caaadr (o) :constant 430 (setter (obj value) ::<void> (CXXR_SETTER A a ad)) 431 (result (Sg_Caar (Sg_Cadr o)))) 432 (define-c-proc caadar (o) :constant 433 (setter (obj value) ::<void> (CXXR_SETTER A a da)) 434 (result (Sg_Caar (Sg_Cdar o)))) 435 (define-c-proc caaddr (o) :constant 436 (setter (obj value) ::<void> (CXXR_SETTER A a dd)) 437 (result (Sg_Caar (Sg_Cddr o)))) 438 (define-c-proc cadaar (o) :constant 439 (setter (obj value) ::<void> (CXXR_SETTER A d aa)) 440 (result (Sg_Cadr (Sg_Caar o)))) 441 (define-c-proc cadadr (o) :constant 442 (setter (obj value) ::<void> (CXXR_SETTER A d ad)) 443 (result (Sg_Cadr (Sg_Cadr o)))) 444 (define-c-proc caddar (o) :constant 445 (setter (obj value) ::<void> (CXXR_SETTER A d da)) 446 (result (Sg_Cadr (Sg_Cdar o)))) 447 (define-c-proc cadddr (o) :constant 448 (setter (obj value) ::<void> (CXXR_SETTER A d dd)) 449 (result (Sg_Cadr (Sg_Cddr o)))) 450 (define-c-proc cdaaar (o) :constant 451 (setter (obj value) ::<void> (CXXR_SETTER D a aa)) 452 (result (Sg_Cdar (Sg_Caar o)))) 453 (define-c-proc cdaadr (o) :constant 454 (setter (obj value) ::<void> (CXXR_SETTER D a ad)) 455 (result (Sg_Cdar (Sg_Cadr o)))) 456 (define-c-proc cdadar (o) :constant 457 (setter (obj value) ::<void> (CXXR_SETTER D a da)) 458 (result (Sg_Cdar (Sg_Cdar o)))) 459 (define-c-proc cdaddr (o) :constant 460 (setter (obj value) ::<void> (CXXR_SETTER D a dd)) 461 (result (Sg_Cdar (Sg_Cddr o)))) 462 (define-c-proc cddaar (o) :constant 463 (setter (obj value) ::<void> (CXXR_SETTER D d aa)) 464 (result (Sg_Cddr (Sg_Caar o)))) 465 (define-c-proc cddadr (o) :constant 466 (setter (obj value) ::<void> (CXXR_SETTER D d ad)) 467 (result (Sg_Cddr (Sg_Cadr o)))) 468 (define-c-proc cdddar (o) :constant 469 (setter (obj value) ::<void> (CXXR_SETTER D d da)) 470 (result (Sg_Cddr (Sg_Cdar o)))) 471 (define-c-proc cddddr (o) :constant 472 (setter (obj value) ::<void> (CXXR_SETTER D d dd)) 473 (result (Sg_Cddr (Sg_Cddr o)))) 474 475 476 (define-c-proc list? (arg0) ::<boolean> :constant SG_PROPER_LISTP) 477 (define-c-proc list (:rest rest) :no-side-effect (inline LIST) (result rest)) 478 (define-c-proc length (lst) ::<fixnum> :constant Sg_Length) 479 ;; are these transparent? 480 (define-c-proc append (:rest lst) :no-side-effect (inline APPEND) Sg_Append) 481 (define-c-proc reverse (lst) :no-side-effect Sg_Reverse) 482 483 (define-c-proc list-tail (lst k::<fixnum> :optional fallback) :constant 484 Sg_ListTail) 485 ;; from where should we expose this? 486 (define-c-proc list-set! (lst k::<fixnum> v) 487 (let ((p (Sg_ListTail lst k SG_FALSE))) 488 (if (SG_PAIRP p) 489 (SG_SET_CAR p v) 490 (assertion-violation 'list-set! "index out of bound" 491 (SG_LIST2 lst (SG_MAKE_INT k)))))) 492 (define-c-proc list-ref (lst k::<fixnum> :optional fallback) :constant 493 (setter list-set!) 494 Sg_ListRef) 495 ;; list miscs 496 (define-c-proc last-pair (lst) :constant Sg_LastPair) 497 498 ;; 11.10 symbols 499 (define-c-proc symbol->string (z::<symbol>) :constant SG_SYMBOL_NAME) 500 501 (define-cise-stmt check-symbol 502 ((_ name s) 503 `(unless (SG_SYMBOLP ,s) 504 (wrong-type-of-argument-violation ',name "symbol" ,s)))) 505 506 (define-c-proc symbol=? (s1::<symbol> s2::<symbol> :rest rest) 507 ::<boolean> :constant 508 (x=? check-symbol SG_EQ symbol=? s1 s2 rest)) 509 510 (define-c-proc string->symbol (z::<string>) :constant Sg_Intern) 511 512 ;; 11.11 characters 513 (define-cise-stmt check-char 514 ((_ name c) 515 `(unless (SG_CHARP ,c) 516 (wrong-type-of-argument-violation ',name "char" ,c)))) 517 518 (define-c-proc char->integer (c::<char>) :constant SG_MAKE_INT) 519 520 (define-c-proc integer->char (ch::<fixnum>) :constant 521 (unless (or (and (<= 0 ch) (<= ch #xD7FF)) 522 (and (<= #xE000 ch) (<= ch #x10FFFF))) 523 (assertion-violation 'integer->char "code point out of range" 524 (SG_MAKE_INT ch))) 525 (result (SG_MAKE_CHAR ch))) 526 527 (define-c-proc char=? (c1 c2 :rest rest) ::<boolean> :constant 528 (x=? check-char SG_EQ char=? c1 c2 rest)) 529 530 (define-cise-stmt char<>=? 531 ((_ compare name first second rest) 532 `(begin 533 (check-char ,name ,first) 534 (check-char ,name ,second) 535 (cond ((SG_NULLP ,rest) 536 (result (,compare ,first ,second))) 537 ((not (,compare ,first ,second)) 538 (result FALSE)) 539 (else 540 (let ((prev ,second)) 541 (dolist (p ,rest) 542 (check-char ,name p) 543 (unless (,compare prev p) 544 (return #f)) 545 (set! prev p)) 546 (result TRUE))))))) 547 548 (define-c-proc char<? (c1 c2 :rest rest) ::<boolean> :constant 549 (char<>=? < char<? c1 c2 rest)) 550 551 (define-c-proc char>? (c1 c2 :rest rest) ::<boolean> :constant 552 (char<>=? > char>? c1 c2 rest)) 553 554 (define-c-proc char<=? (c1 c2 :rest rest) ::<boolean> :constant 555 (char<>=? <= char<=? c1 c2 rest)) 556 557 (define-c-proc char>=? (c1 c2 :rest rest) ::<boolean> :constant 558 (char<>=? >= char>=? c1 c2 rest)) 559 560 ;; 11.12 strings 561 (define-cise-stmt check-string 562 ((_ name s) 563 `(unless (SG_STRINGP ,s) 564 (wrong-type-of-argument-violation ',name "string" ,s)))) 565 566 (define-c-proc make-string (k::<fixnum> :optional (c::<char> #\space)) 567 Sg_ReserveString) 568 (define-c-proc string (:rest rest) :no-side-effect 569 (result (Sg_ListToString rest 0 -1))) 570 (define-c-proc string-length (s::<string>) ::<fixnum> :constant 571 SG_STRING_SIZE) 572 573 (define-c-proc string-ref (s::<string> k::<fixnum> :optional fallback) 574 :constant 575 (setter string-set!) 576 (cond ((SG_UNBOUNDP fallback) 577 (result (SG_MAKE_CHAR (Sg_StringRef s k)))) 578 ((and (<= 0 k) (< k (SG_STRING_SIZE s))) 579 (result (SG_MAKE_CHAR (Sg_StringRef s k)))) 580 (else (result fallback)))) 581 582 ;; string compares 583 (define-c-proc string=? (s1::<string> s2::<string> :rest rest) 584 ::<boolean> :constant 585 (x=? check-string Sg_StringEqual string=? s1 s2 rest)) 586 587 (define-cise-stmt string-compare 588 ((_ compare value name first second rest) 589 `(begin 590 (cond ((SG_NULLP ,rest) 591 (result (,compare (Sg_StringCompare ,first ,second) ,value))) 592 ((not (,compare (Sg_StringCompare ,first ,second) ,value)) 593 (result FALSE)) 594 (else 595 (let ((prev ,second)) 596 (dolist (p ,rest) 597 (check-string ,name p) 598 (unless (,compare (Sg_StringCompare prev p) ,value) 599 (return #f)) 600 (set! prev p)) 601 (result TRUE))))))) 602 603 (define-c-proc string<? (s1::<string> s2::<string> :rest rest) 604 ::<boolean> :constant 605 (string-compare == -1 string<? s1 s2 rest)) 606 (define-c-proc string>? (s1::<string> s2::<string> :rest rest) 607 ::<boolean> :constant 608 (string-compare == 1 string>? s1 s2 rest)) 609 (define-c-proc string<=? (s1::<string> s2::<string> :rest rest) 610 ::<boolean> :constant 611 (string-compare <= 0 string<=? s1 s2 rest)) 612 (define-c-proc string>=? (s1::<string> s2::<string> :rest rest) 613 ::<boolean> :constant 614 (string-compare >= 0 string>=? s1 s2 rest)) 615 616 (define-c-proc substring (s::<string> start::<fixnum> end::<fixnum>) 617 :no-side-effect 618 (when (< start 0) 619 (wrong-type-of-argument-violation 'substring "non negative exact integer" 620 (SG_MAKE_INT start) 621 (SG_LIST3 s (SG_MAKE_INT start) 622 (SG_MAKE_INT end)))) 623 (when (< end 0) 624 (wrong-type-of-argument-violation 'substring "non negative exact integer" 625 (SG_MAKE_INT end) 626 (SG_LIST3 s (SG_MAKE_INT start) 627 (SG_MAKE_INT end)))) 628 (when (< end start) 629 (assertion-violation 'substring "end index is smaller than start index" 630 (SG_LIST3 s (SG_MAKE_INT start) (SG_MAKE_INT end)))) 631 (when (< (SG_STRING_SIZE s) end) 632 (assertion-violation 'substring "end index out of bounds" 633 (SG_LIST3 s (SG_MAKE_INT start) (SG_MAKE_INT end)))) 634 (result (Sg_Substring s start end))) 635 636 (define-c-proc string-append (:rest rest) :no-side-effect Sg_StringAppend) 637 638 ;; we take start+end as optional arguments for srfi-13 639 (define-c-proc string->list 640 (s::<string> :optional (start::<fixnum> 0) (end::<fixnum> -1)) 641 :no-side-effect 642 Sg_StringToList) 643 644 (define-c-proc list->string 645 (o::<list> :optional (start::<fixnum> 0) (end::<fixnum> -1)) 646 :no-side-effect 647 Sg_ListToString) 648 649 ;; we take start+end as optional arguments for srfi-13 650 (define-c-proc string-copy 651 (s::<string> :optional (start::<fixnum> 0) (end::<fixnum> -1)) 652 :no-side-effect 653 Sg_Substring) 654 655 ;; 11.13 vectors 656 (define-c-proc make-vector (size::<fixnum> :optional fill) :no-side-effect 657 (when (SG_UNBOUNDP fill) (set! fill SG_UNDEF)) 658 (result (Sg_MakeVector size fill))) 659 660 (define-c-proc vector (:rest rest) :no-side-effect (inline VECTOR) 661 (result (Sg_ListToVector rest 0 -1))) 662 663 (define-c-proc vector-length (vec::<vector>) ::<fixnum> :constant 664 (inline VEC_LEN) 665 (result (SG_VECTOR_SIZE vec))) 666 667 (define-c-proc vector-ref (vec::<vector> i::<fixnum> :optional fallback) 668 :constant (setter vector-set!) 669 (cond ((or (< i 0) 670 (>= i (SG_VECTOR_SIZE vec))) 671 (when (SG_UNBOUNDP fallback) 672 (assertion-violation 'vector-ref "index out of range" 673 (SG_MAKE_INT i))) 674 (result fallback)) 675 (else (result (SG_VECTOR_ELEMENT vec i))))) 676 677 (define-c-proc vector-set! (vec::<vector> i::<fixnum> obj) ::<void> 678 (when (SG_LITERAL_VECTORP vec) 679 (assertion-violation 'vector-set "attempt to modify immutable vector" 680 (SG_LIST1 vec))) 681 (cond ((or (< i 0) (>= i (SG_VECTOR_SIZE vec))) 682 (assertion-violation 'vector-ref "index out of range" 683 (SG_MAKE_INT i))) 684 (else (set! (SG_VECTOR_ELEMENT vec i) obj)))) 685 686 (define-c-proc vector->list 687 (vec::<vector> :optional (start::<fixnum> 0) (end::<fixnum> -1)) 688 :no-side-effect 689 Sg_VectorToList) 690 691 (define-c-proc list->vector 692 (lst :optional (start::<fixnum> 0) (end::<fixnum> -1)) :no-side-effect 693 (unless (SG_LISTP lst) 694 (wrong-type-of-argument-violation 'list->vector "propert list" lst)) 695 (result (Sg_ListToVector lst start end))) 696 697 (define-c-proc vector-fill! 698 (vec::<vector> fill :optional (start::<fixnum> 0) (end::<fixnum> -1)) 699 ::<void> 700 Sg_VectorFill) 701 702 ;; 11.14 errors and violations 703 (define-c-proc assertion-violation (who message :rest irritants) ::<void> 704 Sg_AssertionViolation) 705 706 (define-c-proc error (who message :rest irritants) ::<void> 707 (let ((condi SG_FALSE)) 708 (if (SG_FALSEP who) 709 (set! condi 710 (Sg_Condition 711 (SG_LIST2 (Sg_MakeError message) 712 (Sg_MakeIrritantsCondition irritants)))) 713 (set! condi 714 (Sg_Condition 715 (SG_LIST3 (Sg_MakeError message) 716 (Sg_MakeWhoCondition who) 717 (Sg_MakeIrritantsCondition irritants))))) 718 (Sg_Raise condi FALSE))) 719 720 ;; we might remove this 721 (define-c-proc scheme-error (who msg :rest irritant) ::<void> 722 (Sg_Error (UC "%S %A %S") who msg irritant)) 723 724 (define-c-proc syntax-error (form :rest irritant) ::<void> 725 Sg_SyntaxError) 726 727 ;; 11.15 control features 728 ;; is apply constant? I think it's depending on the given procedure... 729 (define-c-proc apply (proc::<procedure> arg1 :rest rest) :no-side-effect 730 (inline APPLY) 731 ;; can we consider this no-side-effect? 732 (let ((head::SgObject '()) (tail::SgObject '())) 733 (cond ((SG_NULLP rest) (result (Sg_VMApply proc arg1))) 734 (else 735 (set! head (Sg_Cons arg1 '())) 736 (set! tail head) 737 (dopairs (cp rest) 738 (when (SG_NULLP (SG_CDR cp)) 739 (SG_APPEND head tail (SG_CAR cp)) 740 (break)) 741 (unless (SG_PAIRP (SG_CDR cp)) 742 (assertion-violation 'apply "improper list not allowed" 743 rest)) 744 (SG_APPEND1 head tail (SG_CAR cp))) 745 (result (Sg_VMApply proc head)))))) 746 747 ;; call/cc 748 (define-c-proc call/cc (proc::<procedure>) Sg_VMCallCC) 749 (define-c-proc call-with-current-continuation (proc::<procedure>) Sg_VMCallCC) 750 751 (define-c-proc values (:rest rest) :constant (inline VALUES) Sg_Values) 752 (define-c-proc dynamic-wind (before thunk after) Sg_VMDynamicWind) 753 754 ;; standard libraries 755 ;; 1 Unicode 756 ;; 1.1 characters 757 (define-cise-stmt check-char 758 ((_ name c) 759 `(unless (SG_CHARP ,c) 760 (wrong-type-of-argument-violation ',name "character" ,c)))) 761 762 ;; these can be constant since we always return the same value 763 ;; however no guarantee that unicode spec itself gets changed 764 ;; so just as it is for now. 765 ;; remember unicode 1.1 to unicode 2.0, this may happen in future... 766 (define-c-proc char-upcase (c::<char>) ::<char> :no-side-effect Sg_CharUpCase) 767 (define-c-proc char-downcase (c::<char>) ::<char> :no-side-effect 768 Sg_CharDownCase) 769 (define-c-proc char-titlecase (c::<char>) ::<char> :no-side-effect 770 Sg_CharTitleCase) 771 (define-c-proc char-foldcase (c::<char>) ::<char> :no-side-effect 772 Sg_CharFoldCase) 773 774 (define-c-proc char-general-category (c::<char>) :no-side-effect 775 (result (Sg_CategroyToSymbol (Sg_CharGeneralCategory c)))) 776 777 (define-c-proc char-alphabetic? (c::<char>) ::<boolean> :no-side-effect 778 Sg_CharAlphabeticP) 779 (define-c-proc char-numeric? (c::<char>) ::<boolean> :no-side-effect 780 Sg_CharNumericP) 781 (define-c-proc char-whitespace? (c::<char>) ::<boolean> :no-side-effect 782 Sg_Ucs4WhiteSpaceP) 783 (define-c-proc char-upper-case? (c::<char>) ::<boolean> :no-side-effect 784 Sg_CharUpperCaseP) 785 (define-c-proc char-lower-case? (c::<char>) ::<boolean> :no-side-effect 786 Sg_CharLowerCaseP) 787 (define-c-proc char-title-case? (c::<char>) ::<boolean> :no-side-effect 788 Sg_CharTitleCaseP) 789 790 ;; 1.2 strings 791 ;; for SRFI-13 792 793 ;; these will allocate new string so not constant 794 (define-c-proc string-upcase 795 (s::<string> :optional (start::<fixnum> 0) (end::<fixnum> -1)) 796 :no-side-effect 797 (result (Sg_StringUpCase (Sg_MaybeSubstring s start end)))) 798 799 (define-c-proc string-downcase 800 (s::<string> :optional (start::<fixnum> 0) (end::<fixnum> -1)) 801 :no-side-effect 802 (result (Sg_StringDownCase (Sg_MaybeSubstring s start end)))) 803 804 (define-c-proc string-titlecase 805 (s::<string> :optional (start::<fixnum> 0) (end::<fixnum> -1)) 806 :no-side-effect 807 (result (Sg_StringTitleCase (Sg_MaybeSubstring s start end) FALSE))) 808 809 (define-c-proc string-foldcase 810 (s::<string> :optional (start::<fixnum> 0) (end::<fixnum> -1)) 811 :no-side-effect 812 (result (Sg_StringFoldCase (Sg_MaybeSubstring s start end)))) 813 ;; TODO Should we also add start end to these? 814 (define-c-proc string-normalize-nfd (s::<string>) :no-side-effect 815 Sg_StringNormalizeNfd) 816 (define-c-proc string-normalize-nfkd (s::<string>) :no-side-effect 817 Sg_StringNormalizeNfkd) 818 (define-c-proc string-normalize-nfc (s::<string>) :no-side-effect 819 Sg_StringNormalizeNfc) 820 (define-c-proc string-normalize-nfkc (s::<string>) :no-side-effect 821 Sg_StringNormalizeNfkc) 822 823 ;; 2 Bytevectors 824 ;; 2.2 general operations 825 (define-c-proc native-endianness () :no-side-effect Sg_NativeEndianness) 826 (define-c-proc bytevector=? (bv1::<bytevector> bv2::<bytevector>) 827 ::<boolean> :constant 828 Sg_ByteVectorEqP) 829 830 (define-c-proc bytevector-copy 831 (src::<bytevector> :optional (start::<fixnum> 0) (end::<fixnum> -1)) 832 :no-side-effect 833 Sg_ByteVectorCopy) 834 835 (define-cise-stmt check-non-negative-fixnum 836 ((_ name n) 837 `(when (< ,n 0) 838 (wrong-type-of-argument-violation ',name 839 "non negative exact integer" 840 (SG_MAKE_INT ,n))))) 841 842 (define-c-proc bytevector-copy! (src::<bytevector> sstart::<fixnum> 843 dst::<bytevector> dstart::<fixnum> 844 k::<fixnum>) 845 ::<void> 846 (check-non-negative-fixnum bytevector-copy! sstart) 847 (check-non-negative-fixnum bytevector-copy! dstart) 848 (Sg_ByteVectorCopyX src sstart dst dstart k)) 849 850 (define-c-proc make-bytevector (len::<fixnum> :optional (fill::<fixnum> 0)) 851 :no-side-effect 852 (check-non-negative-fixnum make-bytevector len) 853 (result (Sg_MakeByteVector len (cast int fill)))) 854 855 (define-c-proc bytevector? (o) ::<boolean> :constant SG_BVECTORP) 856 857 (define-c-proc bytevector-length (bv::<bytevector>) ::<fixnum> :constant 858 SG_BVECTOR_SIZE) 859 860 (define-c-proc bytevector-fill! 861 (bv::<bytevector> fill::<fixnum> :optional (start::<fixnum> 0) (end::<fixnum> -1)) ::<void> 862 (Sg_ByteVectorFill bv (cast int fill) start end)) 863 864 ;; 2.3 operations on bytes and octets 865 (define-c-proc u8-list->bytevector (lst) :no-side-effect 866 (result (Sg_ListToByteVector lst 8 FALSE))) 867 868 (define-c-proc bytevector->u8-list (lst) :no-side-effect 869 (result (Sg_ByteVectorToList lst 8 FALSE))) 870 871 (define-cise-stmt bv-check-index 872 ((_ name bv index) 873 `(unless (and (> (SG_BVECTOR_SIZE ,bv) ,index) (>= ,index 0)) 874 (assertion-violation ',name "index out of range" 875 (SG_LIST2 ,bv (SG_MAKE_INT ,index))))) 876 ((_ name bv index offset) 877 `(let ((len::long (SG_BVECTOR_SIZE ,bv))) 878 (unless (and (> len ,offset) 879 (< ,index (- len ,offset))) 880 (assertion-violation ',name "index out of range" 881 (SG_LIST2 ,bv (SG_MAKE_INT ,index))))))) 882 883 (define-cise-stmt bv-check-literal 884 ((_ name bv) 885 `(when (SG_LITERAL_BVECTORP ,bv) 886 (assertion-violation ',name "attempt to modify literal bytevector" 887 ,bv)))) 888 889 (define-c-proc bytevector-u8-ref (bv::<bytevector> index::<fixnum>) 890 ::<fixnum> :constant 891 (setter bytevector-u8-set!) 892 (bv-check-index bytevector-u8-ref bv index) 893 (result (SG_BVECTOR_ELEMENT bv index))) 894 895 (define-c-proc bytevector-u8-set! 896 (bv::<bytevector> index::<fixnum> value::<fixnum>) ::<void> 897 (bv-check-literal bytevector-u8-set! bv) 898 (bv-check-index bytevector-u8-set! bv index) 899 (unless (SG_IS_OCTET value) 900 (assertion-violation 'bytevector-u8-set! 901 "value out of range. must be 0 <= value <= 255" 902 (SG_MAKE_INT value))) 903 (set! (SG_BVECTOR_ELEMENT bv index) (cast uint8_t value))) 904 905 (define-c-proc bytevector-s8-ref (bv::<bytevector> index::<fixnum>) 906 ::<fixnum> :constant 907 (setter bytevector-s8-set!) 908 (bv-check-index bytevector-s8-ref bv index) 909 (result (cast int8_t (SG_BVECTOR_ELEMENT bv index)))) 910 911 (define-c-proc bytevector-s8-set! 912 (bv::<bytevector> index::<fixnum> value::<fixnum>) ::<void> 913 (bv-check-literal bytevector-s8-set! bv) 914 (bv-check-index bytevector-s8-set! bv index) 915 (unless (SG_IS_BYTE value) 916 (assertion-violation 'bytevector-s8-set! 917 "value out of range. must be -128 <= value <= 127" 918 (SG_MAKE_INT value))) 919 (set! (SG_BVECTOR_ELEMENT bv index) (cast uint8_t value))) 920 921 (define-cise-stmt bv-check-align 922 ((_ name index align) 923 `(unless (== (% ,index ,align) 0) 924 (assertion-violation ',name "index not aligned" 925 (SG_MAKE_INT ,index))))) 926 927 (define-cise-stmt bv-check-value 928 ((_ name value min max) 929 (let ((v (gensym "cise__"))) 930 `(let ((,v :: long ,value)) 931 (unless (and (<= ,min ,v) 932 (<= ,v ,max)) 933 (assertion-violation ',name "value out of range" 934 (SG_MAKE_INT ,v))))))) 935 936 ;; 2.5 operations on 16-bit integers 937 ;; u16 938 (define-c-proc bytevector-u16-native-ref 939 (bv::<bytevector> index::<fixnum>) ::<fixnum> :constant 940 (setter bytevector-u16-native-set!) 941 (bv-check-index bytevector-u16-native-ref bv index 1) 942 (bv-check-align bytevector-u16-native-ref index 2) 943 (result (Sg_ByteVectorU16NativeRef bv index))) 944 945 (define-c-proc bytevector-u16-native-set! 946 (bv::<bytevector> index::<fixnum> value::<fixnum>) ::<void> 947 (bv-check-literal bytevector-u16-native-set! bv) 948 (bv-check-index bytevector-u16-native-set! bv index 1) 949 (bv-check-value bytevector-u16-native-set! value 0 #xFFFF) 950 (Sg_ByteVectorU16NativeSet bv index value)) 951 952 (define-c-proc bytevector-u16-ref 953 (bv::<bytevector> index::<fixnum> endian::<symbol>) ::<fixnum> :constant 954 ;;(setter bytevector-u16-set!) 955 (bv-check-index bytevector-u16-ref bv index 1) 956 (cond ((SG_EQ endian 'big) 957 (result (Sg_ByteVectorU16BigRef bv index))) 958 ((SG_EQ endian 'little) 959 (result (Sg_ByteVectorU16LittleRef bv index))) 960 (else 961 (assertion-violation 'bytevector-u16-ref "unsupported endianness" 962 endian)))) 963 964 (define-c-proc bytevector-u16-set! 965 (bv::<bytevector> index::<fixnum> value::<fixnum> endian::<symbol>) ::<void> 966 (bv-check-literal bytevector-u16-set! bv) 967 (bv-check-index bytevector-u16-set! bv index 1) 968 (bv-check-value bytevector-u16-set! value 0 #xFFFF) 969 (cond ((SG_EQ endian 'big) 970 (Sg_ByteVectorU16BigSet bv index value)) 971 ((SG_EQ endian 'little) 972 (Sg_ByteVectorU16LittleSet bv index value)) 973 (else 974 (assertion-violation 'bytevector-u16-set! 975 "unsupported endianness" endian)))) 976 977 ;; s16 978 (define-c-proc bytevector-s16-native-ref 979 (bv::<bytevector> index::<fixnum>) ::<fixnum> :constant 980 (setter bytevector-s16-native-set!) 981 (bv-check-index bytevector-s16-native-ref bv index 1) 982 (bv-check-align bytevector-s16-native-ref index 2) 983 (result (Sg_ByteVectorS16NativeRef bv index))) 984 985 (define-c-proc bytevector-s16-native-set! 986 (bv::<bytevector> index::<fixnum> value::<fixnum>) ::<void> 987 (bv-check-literal bytevector-s16-native-set! bv) 988 (bv-check-index bytevector-s16-native-set! bv index 1) 989 (bv-check-value bytevector-s16-native-set! value #x-8000 #x7FFF) 990 (Sg_ByteVectorS16NativeSet bv index value)) 991 992 (define-c-proc bytevector-s16-ref 993 (bv::<bytevector> index::<fixnum> endian::<symbol>) ::<fixnum> :constant 994 ;;(setter bytevector-s16-set!) 995 (bv-check-index bytevector-s16-ref bv index 1) 996 (cond ((SG_EQ endian 'big) 997 (result (Sg_ByteVectorS16BigRef bv index))) 998 ((SG_EQ endian 'little) 999 (result (Sg_ByteVectorS16LittleRef bv index))) 1000 (else 1001 (assertion-violation 'bytevector-s16-ref "unsupported endianness" 1002 endian)))) 1003 1004 (define-c-proc bytevector-s16-set! 1005 (bv::<bytevector> index::<fixnum> value::<fixnum> endian::<symbol>) ::<void> 1006 (bv-check-literal bytevector-s16-set! bv) 1007 (bv-check-index bytevector-s16-set! bv index 1) 1008 (bv-check-value bytevector-s16-set! value #x-8000 #x7FFF) 1009 (cond ((SG_EQ endian 'big) 1010 (Sg_ByteVectorS16BigSet bv index value)) 1011 ((SG_EQ endian 'little) 1012 (Sg_ByteVectorS16LittleSet bv index value)) 1013 (else 1014 (assertion-violation 'bytevector-s16-set! "unsupported endianness" 1015 endian)))) 1016 ;; 2.6 operations on 32-bit integers 1017 ;; u32 1018 (define-c-proc bytevector-u32-native-ref (bv::<bytevector> index::<fixnum>) 1019 :constant 1020 (setter bytevector-u32-native-set!) 1021 (bv-check-index bytevector-u32-native-ref bv index 3) 1022 (bv-check-align bytevector-u32-native-ref index 4) 1023 (result (Sg_MakeIntegerFromU32 (Sg_ByteVectorU32NativeRef bv index)))) 1024 1025 (define-c-proc bytevector-u32-native-set! 1026 (bv::<bytevector> index::<fixnum> v::<number>) ::<void> 1027 (bv-check-literal bytevector-u32-native-set! bv) 1028 (bv-check-index bytevector-u32-native-set! bv index 3) 1029 (let ((value::uint32_t 0)) 1030 (cond ((SG_INTP v) 1031 (bv-check-value bytevector-u32-native-set! (SG_INT_VALUE v) 1032 0 UINT32_MAX) 1033 (set! value (cast uint32_t (SG_INT_VALUE v)))) 1034 ((SG_BIGNUMP v) 1035 (set! value (Sg_BignumToU32 v SG_CLAMP_NONE NULL))) 1036 (else 1037 (wrong-type-of-argument-violation 'bytevector-u32-native-set! 1038 "exact integer" v))) 1039 (Sg_ByteVectorU32NativeSet bv index value))) 1040 1041 (define-c-proc bytevector-u32-ref 1042 (bv::<bytevector> index::<fixnum> endian::<symbol>) :constant 1043 ;;(setter bytevector-u32-set!) 1044 (bv-check-index bytevector-u32-ref bv index 3) 1045 (cond ((SG_EQ endian 'big) 1046 (result (Sg_MakeIntegerFromU32 (Sg_ByteVectorU32BigRef bv index)))) 1047 ((SG_EQ endian 'little) 1048 (result (Sg_MakeIntegerFromU32 1049 (Sg_ByteVectorU32LittleRef bv index)))) 1050 (else 1051 (assertion-violation 'bytevector-u32-ref 1052 "unsupported endianness" endian)))) 1053 1054 (define-c-proc bytevector-u32-set! 1055 (bv::<bytevector> index::<fixnum> v::<number> endian::<symbol>) ::<void> 1056 (bv-check-literal bytevector-u32-set! bv) 1057 (bv-check-index bytevector-u32-set! bv index 3) 1058 (let ((value::uint32_t 0)) 1059 (cond ((SG_INTP v) 1060 ;; for 64 bit environment fixnum can be more than 32 bits 1061 (bv-check-value bytevector-u32-set! (SG_INT_VALUE v) 1062 0 UINT32_MAX) 1063 (set! value (cast uint32_t (SG_INT_VALUE v)))) 1064 ((SG_BIGNUMP v) 1065 (set! value (Sg_BignumToU32 v SG_CLAMP_NONE NULL))) 1066 (else 1067 (wrong-type-of-argument-violation 'bytevector-u32-set! 1068 "exact integer" v))) 1069 (cond ((SG_EQ endian 'big) 1070 (Sg_ByteVectorU32BigSet bv index value)) 1071 ((SG_EQ endian 'little) 1072 (Sg_ByteVectorU32LittleSet bv index value)) 1073 (else 1074 (assertion-violation 'bytevector-u32-set! 1075 "unsupported endianness" endian))))) 1076 ;; s32 1077 (define-c-proc bytevector-s32-native-ref (bv::<bytevector> index::<fixnum>) 1078 :constant 1079 (setter bytevector-s32-native-set!) 1080 (bv-check-index bytevector-s32-native-ref bv index 3) 1081 (bv-check-align bytevector-s32-native-ref index 4) 1082 (result (Sg_MakeIntegerFromS32 (Sg_ByteVectorS32NativeRef bv index)))) 1083 1084 (define-c-proc bytevector-s32-native-set! 1085 (bv::<bytevector> index::<fixnum> v::<number>) ::<void> 1086 (bv-check-literal bytevector-s32-native-set! bv) 1087 (bv-check-index bytevector-s32-native-set! bv index 3) 1088 (let ((value::int32_t 0)) 1089 (cond ((SG_INTP v) 1090 (bv-check-value bytevector-s32-native-set! (SG_INT_VALUE v) 1091 INT32_MIN INT32_MAX) 1092 (set! value (cast int32_t (SG_INT_VALUE v)))) 1093 ((SG_BIGNUMP v) 1094 (set! value (Sg_BignumToS32 v SG_CLAMP_NONE NULL))) 1095 (else 1096 (wrong-type-of-argument-violation 'bytevector-s32-native-set! 1097 "exact integer" v))) 1098 (Sg_ByteVectorS32NativeSet bv index value))) 1099 1100 (define-c-proc bytevector-s32-ref 1101 (bv::<bytevector> index::<fixnum> endian::<symbol>) :constant 1102 ;;(setter bytevector-s32-set!) 1103 (bv-check-index bytevector-s32-ref bv index 3) 1104 (cond ((SG_EQ endian 'big) 1105 (result (Sg_MakeIntegerFromS32 (Sg_ByteVectorS32BigRef bv index)))) 1106 ((SG_EQ endian 'little) 1107 (result (Sg_MakeIntegerFromS32 1108 (Sg_ByteVectorS32LittleRef bv index)))) 1109 (else 1110 (assertion-violation 'bytevector-s32-ref 1111 "unsupported endianness" endian)))) 1112 1113 (define-c-proc bytevector-s32-set! 1114 (bv::<bytevector> index::<fixnum> v::<number> endian::<symbol>) ::<void> 1115 (bv-check-literal bytevector-s32-set! bv) 1116 (bv-check-index bytevector-s32-set! bv index 3) 1117 (let ((value::int32_t 0)) 1118 (cond ((SG_INTP v) 1119 (bv-check-value bytevector-s32-set! (SG_INT_VALUE v) 1120 INT32_MIN INT32_MAX) 1121 (set! value (cast int32_t (SG_INT_VALUE v)))) 1122 ((SG_BIGNUMP v) 1123 (set! value (Sg_BignumToS32 v SG_CLAMP_NONE NULL))) 1124 (else 1125 (wrong-type-of-argument-violation 'bytevector-s32-set! 1126 "exact integer" v))) 1127 (cond ((SG_EQ endian 'big) 1128 (Sg_ByteVectorS32BigSet bv index value)) 1129 ((SG_EQ endian 'little) 1130 (Sg_ByteVectorS32LittleSet bv index value)) 1131 (else 1132 (assertion-violation 'bytevector-s32-set! 1133 "unsupported endianness" endian))))) 1134 ;; 2.7 operations on 64-bit integers 1135 ;; u64 1136 (define-c-proc bytevector-u64-native-ref (bv::<bytevector> index::<fixnum>) 1137 :constant 1138 (setter bytevector-u64-native-set!) 1139 (bv-check-index bytevector-u64-native-ref bv index 7) 1140 (bv-check-align bytevector-u64-native-ref index 8) 1141 (result (Sg_MakeIntegerFromU64 (Sg_ByteVectorU64NativeRef bv index)))) 1142 1143 (define-c-proc bytevector-u64-native-set! 1144 (bv::<bytevector> index::<fixnum> v::<number>) ::<void> 1145 (bv-check-literal bytevector-u64-native-set! bv) 1146 (bv-check-index bytevector-u64-native-set! bv index 7) 1147 (let ((value::uint64_t 0)) 1148 (cond ((SG_INTP v) 1149 ;; we don't have to check the limit value 1150 ;; unless we would get 128 bit environment... 1151 (when (< (SG_INT_VALUE v) 0) 1152 (assertion-violation 'bytevector-u64-native-set! 1153 "value out of range" v)) 1154 (set! value (cast uint64_t (SG_INT_VALUE v)))) 1155 ((SG_BIGNUMP v) 1156 (set! value (Sg_BignumToU64 v SG_CLAMP_NONE NULL))) 1157 (else 1158 (wrong-type-of-argument-violation 'bytevector-u64-native-set! 1159 "exact integer" v))) 1160 (Sg_ByteVectorU64NativeSet bv index value))) 1161 1162 (define-c-proc bytevector-u64-ref 1163 (bv::<bytevector> index::<fixnum> endian::<symbol>) :constant 1164 ;;(setter bytevector-u64-set!) 1165 (bv-check-index bytevector-u64-ref bv index 7) 1166 (cond ((SG_EQ endian 'big) 1167 (result (Sg_MakeIntegerFromU64 1168 (Sg_ByteVectorU64BigRef bv index)))) 1169 ((SG_EQ endian 'little) 1170 (result (Sg_MakeIntegerFromU64 1171 (Sg_ByteVectorU64LittleRef bv index)))) 1172 (else 1173 (assertion-violation 'bytevector-u64-ref 1174 "unsupported endianness" endian)))) 1175 1176 (define-c-proc bytevector-u64-set! 1177 (bv::<bytevector> index::<fixnum> v::<number> endian::<symbol>) ::<void> 1178 (bv-check-literal bytevector-u64-set! bv) 1179 (bv-check-index bytevector-u64-set! bv index 7) 1180 (let ((value::uint64_t 0)) 1181 (cond ((SG_INTP v) 1182 (when (< (SG_INT_VALUE v) 0) 1183 (assertion-violation 'bytevector-u64-set! 1184 "value out of range" v)) 1185 (set! value (cast uint64_t (SG_INT_VALUE v)))) 1186 ((SG_BIGNUMP v) 1187 (set! value (Sg_BignumToU64 v SG_CLAMP_NONE NULL))) 1188 (else 1189 (wrong-type-of-argument-violation 'bytevector-u64-set! 1190 "exact integer" v))) 1191 (cond ((SG_EQ endian 'big) 1192 (Sg_ByteVectorU64BigSet bv index value)) 1193 ((SG_EQ endian 'little) 1194 (Sg_ByteVectorU64LittleSet bv index value)) 1195 (else 1196 (assertion-violation 'bytevector-u64-set! 1197 "unsupported endianness" endian))))) 1198 ;; s64 1199 (define-c-proc bytevector-s64-native-ref (bv::<bytevector> index::<fixnum>) 1200 :constant 1201 (setter bytevector-s64-native-set!) 1202 (bv-check-index bytevector-s64-native-ref bv index 7) 1203 (bv-check-align bytevector-s64-native-ref index 8) 1204 (result (Sg_MakeIntegerFromS64 (Sg_ByteVectorS64NativeRef bv index)))) 1205 1206 (define-c-proc bytevector-s64-native-set! 1207 (bv::<bytevector> index::<fixnum> v::<number>) ::<void> 1208 (bv-check-literal bytevector-s64-native-set! bv) 1209 (bv-check-index bytevector-s64-native-set! bv index 7) 1210 (let ((value::int64_t 0)) 1211 (cond ((SG_INTP v) 1212 (when (or (< (SG_INT_VALUE v) SG_INT_MIN) 1213 (> (SG_INT_VALUE v) SG_INT_MAX)) 1214 (assertion-violation 'bytevector-s64-native-set! 1215 "value out of range" v)) 1216 (set! value (cast int64_t (SG_INT_VALUE v)))) 1217 ((SG_BIGNUMP v) 1218 (set! value (Sg_BignumToS64 v SG_CLAMP_NONE NULL))) 1219 (else 1220 (wrong-type-of-argument-violation 'bytevector-s64-native-set! 1221 "exact integer" v))) 1222 (Sg_ByteVectorS64NativeSet bv index value))) 1223 1224 (define-c-proc bytevector-s64-ref 1225 (bv::<bytevector> index::<fixnum> endian::<symbol>) :constant 1226 ;;(setter bytevector-s64-set!) 1227 (bv-check-index bytevector-s64-ref bv index 7) 1228 (cond ((SG_EQ endian 'big) 1229 (result (Sg_MakeIntegerFromS64 (Sg_ByteVectorS64BigRef bv index)))) 1230 ((SG_EQ endian 'little) 1231 (result (Sg_MakeIntegerFromS64 1232 (Sg_ByteVectorS64LittleRef bv index)))) 1233 (else 1234 (assertion-violation 'bytevector-s64-ref 1235 "unsupported endianness" endian)))) 1236 1237 (define-c-proc bytevector-s64-set! 1238 (bv::<bytevector> index::<fixnum> v::<number> endian::<symbol>) ::<void> 1239 (bv-check-literal bytevector-s64-set! bv) 1240 (bv-check-index bytevector-s64-set! bv index 7) 1241 (let ((value::int64_t 0)) 1242 (cond ((SG_INTP v) 1243 (when (or (< (SG_INT_VALUE v) SG_INT_MIN) 1244 (> (SG_INT_VALUE v) SG_INT_MAX)) 1245 (assertion-violation 'bytevector-s64-set! 1246 "value out of range" v)) 1247 (set! value (cast int64_t (SG_INT_VALUE v)))) 1248 ((SG_BIGNUMP v) 1249 (set! value (Sg_BignumToS64 v SG_CLAMP_NONE NULL))) 1250 (else 1251 (wrong-type-of-argument-violation 'bytevector-s64-set! 1252 "exact integer" v))) 1253 (cond ((SG_EQ endian 'big) 1254 (Sg_ByteVectorS64BigSet bv index value)) 1255 ((SG_EQ endian 'little) 1256 (Sg_ByteVectorS64LittleSet bv index value)) 1257 (else 1258 (assertion-violation 'bytevector-s64-set! 1259 "unsupported endianness" endian))))) 1260 ;; 2.8 operations on ieee-754 representations 1261 ;; ieee-single 1262 (define-c-proc bytevector-ieee-single-native-ref 1263 (bv::<bytevector> index::<fixnum>) :constant 1264 (setter bytevector-ieee-single-native-set!) 1265 (bv-check-index bytevector-ieee-single-native-ref bv index 3) 1266 (bv-check-align bytevector-ieee-single-native-ref index 4) 1267 (result (Sg_MakeFlonum (Sg_ByteVectorIEEESingleNativeRef bv index)))) 1268 1269 (define-c-proc bytevector-ieee-single-ref 1270 (bv::<bytevector> index::<fixnum> endian::<symbol>) :constant 1271 ;;(setter bytevector-ieee-single-set!) 1272 (bv-check-index bytevector-ieee-single-ref bv index 3) 1273 (cond ((SG_EQ endian 'big) 1274 (result (Sg_MakeFlonum (Sg_ByteVectorIEEESingleBigRef bv index)))) 1275 ((SG_EQ endian 'little) 1276 (result (Sg_MakeFlonum (Sg_ByteVectorIEEESingleLittleRef bv index)))) 1277 (else 1278 (assertion-violation 'bytevector-ieee-single-ref 1279 "unsupported endianness" endian)))) 1280 1281 (define-c-proc bytevector-ieee-single-native-set! 1282 (bv::<bytevector> index::<fixnum> v::<number>) ::<void> 1283 (bv-check-literal bytevector-ieee-single-native-set! bv) 1284 (bv-check-index bytevector-ieee-single-native-set! bv index 3) 1285 (bv-check-align bytevector-ieee-single-native-set! index 4) 1286 (check-real bytevector-ieee-single-native-set! v) 1287 (let ((value::double (Sg_GetDouble v))) 1288 (Sg_ByteVectorIEEESingleNativeSet bv index (cast float value)))) 1289 1290 (define-c-proc bytevector-ieee-single-set! 1291 (bv::<bytevector> index::<fixnum> v::<number> endian::<symbol>) ::<void> 1292 (bv-check-literal bytevector-ieee-single-set! bv) 1293 (bv-check-index bytevector-ieee-single-set! bv index 3) 1294 (check-real bytevector-ieee-single-set! v) 1295 (let ((value::double (Sg_GetDouble v))) 1296 (cond ((SG_EQ endian 'big) 1297 (Sg_ByteVectorIEEESingleBigSet bv index (cast float value))) 1298 ((SG_EQ endian 'little) 1299 (Sg_ByteVectorIEEESingleLittleSet bv index (cast float value))) 1300 (else 1301 (assertion-violation 'bytevector-ieee-single-set! 1302 "unsupported endianness" endian))))) 1303 ;; ieee-double 1304 (define-c-proc bytevector-ieee-double-native-ref 1305 (bv::<bytevector> index::<fixnum>) :constant 1306 (setter bytevector-ieee-double-native-set!) 1307 (bv-check-index bytevector-ieee-double-native-ref bv index 7) 1308 (bv-check-align bytevector-ieee-double-native-ref index 8) 1309 (result (Sg_MakeFlonum (Sg_ByteVectorIEEEDoubleNativeRef bv index)))) 1310 1311 (define-c-proc bytevector-ieee-double-ref 1312 (bv::<bytevector> index::<fixnum> endian::<symbol>) :constant 1313 ;;(setter bytevector-ieee-double-set!) 1314 (bv-check-index bytevector-ieee-double-ref bv index 7) 1315 (cond ((SG_EQ endian 'big) 1316 (result (Sg_MakeFlonum (Sg_ByteVectorIEEEDoubleBigRef bv index)))) 1317 ((SG_EQ endian 'little) 1318 (result (Sg_MakeFlonum (Sg_ByteVectorIEEEDoubleLittleRef bv index)))) 1319 (else 1320 (assertion-violation 'bytevector-ieee-double-ref 1321 "unsupported endianness" endian)))) 1322 1323 (define-c-proc bytevector-ieee-double-native-set! 1324 (bv::<bytevector> index::<fixnum> v::<number>) ::<void> 1325 (bv-check-literal bytevector-ieee-double-native-set! bv) 1326 (bv-check-index bytevector-ieee-double-native-set! bv index 7) 1327 (bv-check-align bytevector-ieee-double-native-set! index 8) 1328 (check-real bytevector-ieee-double-native-set! v) 1329 (let ((value::double (Sg_GetDouble v))) 1330 (Sg_ByteVectorIEEEDoubleNativeSet bv index value))) 1331 1332 (define-c-proc bytevector-ieee-double-set! 1333 (bv::<bytevector> index::<fixnum> v::<number> endian::<symbol>) ::<void> 1334 (bv-check-literal bytevector-ieee-double-set! bv) 1335 (bv-check-index bytevector-ieee-double-set! bv index 7) 1336 (check-real bytevector-ieee-double-set! v) 1337 (let ((value::double (Sg_GetDouble v))) 1338 (cond ((SG_EQ endian 'big) 1339 (Sg_ByteVectorIEEEDoubleBigSet bv index value)) 1340 ((SG_EQ endian 'little) 1341 (Sg_ByteVectorIEEEDoubleLittleSet bv index value)) 1342 (else 1343 (assertion-violation 'bytevector-ieee-double-set! 1344 "unsupported endianness" endian))))) 1345 ;; 2.9 operations on strings 1346 ;; converter 1347 ;; utf8 <-> string 1348 (define-cise-expr utf8-tail? 1349 ((_ b) 1350 `(and (<= #x80 ,b) (<= ,b #xbf)))) 1351 (define-cfn check-utf8-3bytes (bv i::long) 1352 ::int :static 1353 (let ((first::int (SG_BVECTOR_ELEMENT bv i)) 1354 (second::int (SG_BVECTOR_ELEMENT bv (+ i 1))) 1355 (third::int (SG_BVECTOR_ELEMENT bv (+ i 2)))) 1356 (cond ((not (utf8-tail? third)) (return FALSE)) 1357 ((not (or (and (== #xe0 first) (<= #xa0 second) (<= second #xbf)) 1358 (and (== #xed first) (<= #x80 second) (<= second #x9f)) 1359 (and (<= #xe1 first) (<= first #xec) (utf8-tail? second)) 1360 (and (or (== #xee first) (== #xef first)) 1361 (utf8-tail? second)))) 1362 (return FALSE)) 1363 (else (return TRUE))))) 1364 (define-cfn check-utf8-4bytes (bv i::long) 1365 ::int :static 1366 (let ((first::int (SG_BVECTOR_ELEMENT bv i)) 1367 (second::int (SG_BVECTOR_ELEMENT bv (+ i 1))) 1368 (third::int (SG_BVECTOR_ELEMENT bv (+ i 2))) 1369 (forth::int (SG_BVECTOR_ELEMENT bv (+ i 3)))) 1370 (cond ((or (not (utf8-tail? third)) (not (utf8-tail? forth))) 1371 (return FALSE)) 1372 ((not (or (and (== #xf0 first) (<= #x90 second) (<= second #xbf)) 1373 (and (== #xf4 first) (<= #x80 second) (<= second #x8f)) 1374 (and (<= #xf1 first) (<= first #xf3) 1375 (utf8-tail? second)))) 1376 (return FALSE)) 1377 (else (return TRUE))))) 1378 (define-c-proc utf8->string (bv::<bytevector> :optional (start::<fixnum> 0) 1379 (end::<fixnum> -1)) 1380 :no-side-effect 1381 (let ((s) 1382 (count::long 0) 1383 (size::long (SG_BVECTOR_SIZE bv)) 1384 (i::long start)) 1385 (SG_CHECK_START_END start end size) 1386 (while (< i end) 1387 (post++ count) 1388 (let ((f::uint8_t (SG_BVECTOR_ELEMENT bv i))) 1389 (+= i (?: (< f #x80) 1 1390 (?: (and (<= #xc2 f) (<= f #xdf) 1391 (utf8-tail? (SG_BVECTOR_ELEMENT bv (+ i 1)))) 2 1392 (?: (and (<= #xe0 f) (<= f #xef) 1393 (check-utf8-3bytes bv i)) 3 1394 ;; the last one is error replacing so 1 1395 (?: (and (<= #xf0 f) (<= f #xf4) 1396 (check-utf8-4bytes bv i)) 4 1))))))) 1397 (set! s (Sg_ReserveString count 0)) 1398 (Sg_ConvertUtf8BufferToUcs4 (Sg_MakeUtf8Codec) 1399 (+ (SG_BVECTOR_ELEMENTS bv) start) size 1400 (SG_STRING_VALUE s) count NULL 1401 SG_REPLACE_ERROR FALSE) 1402 (result s))) 1403 1404 (define-c-proc string->utf8 (s::<string> :optional (start::<fixnum> 0) 1405 (end::<fixnum> -1)) 1406 :no-side-effect 1407 (let ((bv) 1408 (count::long 0) 1409 (size::long (SG_STRING_SIZE s))) 1410 (SG_CHECK_START_END start end size) 1411 (dotimes (i (- end start) long) 1412 (let ((ucs4::SgChar (SG_STRING_VALUE_AT s (+ i start)))) 1413 (+= count (?: (< ucs4 #x80) 1 1414 (?: (< ucs4 #x800) 2 1415 (?: (< ucs4 #x10000) 3 1416 ;; the last one is error replacing so 2 1417 (?: (< ucs4 #x200000) 4 2))))))) 1418 (set! bv (Sg_MakeByteVector count 0)) 1419 (set! count 0) 1420 (dotimes (i (- end start) long) 1421 (+= count (Sg_ConvertUcs4ToUtf8 1422 (SG_STRING_VALUE_AT s (+ i start)) 1423 (+ (SG_BVECTOR_ELEMENTS bv) count) 1424 SG_REPLACE_ERROR))) 1425 (result bv))) 1426 1427 ;; utf16 <-> string 1428 (define-c-proc utf16->string (bv::<bytevector> endian::<symbol> 1429 :optional mandatory) 1430 :no-side-effect 1431 (let ((endianness::SgEndianness NO_BOM) 1432 (skipBOM::int FALSE)) 1433 (when (SG_UNBOUNDP mandatory) 1434 (set! endianness (Sg_Utf16CheckBOM bv)) 1435 (when (not (== endianness NO_BOM)) (set! skipBOM TRUE))) 1436 (when (or (and (not (SG_UNBOUNDP mandatory)) 1437 (not (SG_FALSEP mandatory))) 1438 (== endianness NO_BOM)) 1439 (cond ((SG_EQ endian 'little) 1440 (set! endianness UTF_16LE)) 1441 ((SG_EQ endian 'big) 1442 (set! endianness UTF_16BE)) 1443 (else 1444 (assertion-violation 1445 'utf16->string "endianness should be little or big" endian)))) 1446 (let ((skipSize::int 0) 1447 (codec SG_UNDEF) 1448 (trans::SgTranscoder)) 1449 (when skipBOM (set! skipSize 2)) 1450 (set! codec (Sg_MakeUtf16Codec endianness)) 1451 (Sg_InitTranscoder (& trans) codec E_NONE SG_REPLACE_ERROR) 1452 ;; TODO guard 1453 (result (Sg_ByteVectorToString bv (& trans) skipSize -1))))) 1454 1455 (define-c-proc string->utf16 (s::<string> :optional endian::<symbol>) 1456 :no-side-effect 1457 (let ((endianness::SgEndianness UTF_16BE) 1458 (trans::SgTranscoder)) 1459 (if (not (SG_UNBOUNDP endian)) 1460 (cond ((SG_EQ endian 'little) 1461 (set! endianness UTF_16LE)) 1462 ((SG_EQ endian 'big) 1463 (set! endianness UTF_16BE)) 1464 (else 1465 (assertion-violation 1466 'string->utf16 "endianness should be little or big" endian)))) 1467 (Sg_InitTranscoder (& trans) (Sg_MakeUtf16Codec endianness) 1468 E_NONE SG_REPLACE_ERROR) 1469 (result (Sg_StringToByteVector s (& trans) 0 -1)))) 1470 1471 1472 (define-c-proc string->utf32 (s::<string> :optional endian::<symbol>) 1473 :no-side-effect 1474 (let ((endianness::SgEndianness UTF_32BE) 1475 (trans::SgTranscoder)) 1476 (if (not (SG_UNBOUNDP endian)) 1477 (cond ((SG_EQ endian 'little) 1478 (set! endianness UTF_32LE)) 1479 ((SG_EQ endian 'big) 1480 (set! endianness UTF_32BE)) 1481 (else 1482 (assertion-violation 1483 'string->utf32 "endianness should be little or big" endian)))) 1484 (Sg_InitTranscoder (& trans) (Sg_MakeUtf32Codec endianness) 1485 E_NONE SG_REPLACE_ERROR) 1486 (result (Sg_StringToByteVector s (& trans) 0 -1)))) 1487 1488 (define-c-proc utf32->string (bv::<bytevector> endian::<symbol> 1489 :optional mandatory) 1490 :no-side-effect 1491 (let ((endianness::SgEndianness NO_BOM) 1492 (skipBOM::int FALSE)) 1493 (when (SG_UNBOUNDP mandatory) 1494 (set! endianness (Sg_Utf32CheckBOM bv)) 1495 (if (not (== endianness NO_BOM)) 1496 (set! skipBOM TRUE))) 1497 (when (or (and (not (SG_UNBOUNDP mandatory)) 1498 (not (SG_FALSEP mandatory))) 1499 (== endianness NO_BOM)) 1500 (cond ((SG_EQ endian 'little) 1501 (set! endianness UTF_32LE)) 1502 ((SG_EQ endian 'big) 1503 (set! endianness UTF_32BE)) 1504 (else 1505 (assertion-violation 1506 'utf32->string "endianness should be little or big" endian)))) 1507 (let ((skipSize::int 0) 1508 (codec SG_UNDEF) 1509 (trans::SgTranscoder)) 1510 (if skipBOM 1511 (set! skipSize 4)) 1512 (set! codec (Sg_MakeUtf32Codec endianness)) 1513 (Sg_InitTranscoder (& trans) codec E_NONE SG_REPLACE_ERROR) 1514 ;; TODO guard 1515 (result (Sg_ByteVectorToString bv (& trans) skipSize -1))))) 1516 1517 ;; 3 List utilities 1518 (define-c-proc memq (arg0 arg1) :constant Sg_Memq) 1519 (define-c-proc memv (arg0 arg1) :constant Sg_Memv) 1520 (define-c-proc assq (obj alist) :constant Sg_Assq) 1521 (define-c-proc assv (obj alist) :constant Sg_Assv) 1522 1523 (define-c-proc cons* (:rest rest) :no-side-effect 1524 (let ((h '()) (t '())) 1525 (when (SG_PAIRP rest) 1526 (dopairs (cp rest) 1527 (unless (SG_PAIRP (SG_CDR cp)) 1528 (if (SG_NULLP h) 1529 (set! h (SG_CAR cp)) 1530 (SG_SET_CDR t (SG_CAR cp))) 1531 (break)) 1532 (SG_APPEND1 h t (SG_CAR cp)))) 1533 (result h))) 1534 1535 ;; 7 Exceptions and conditions 1536 ;; 7.1 exceptions 1537;; these are moved to Scheme 1538;; (define-c-proc with-exception-handler (handler thunk) 1539;; Sg_VMWithExceptionHandler) 1540;; 1541;; (define-c-proc raise (c) 1542;; (result (Sg_Raise c FALSE))) 1543;; 1544;; (define-c-proc raise-continuable (c) 1545;; (result (Sg_Raise c TRUE))) 1546 1547 ;; 8 I/O 1548 ;; 8.2 port i/o 1549 ;; 8.2.3 buffer modes 1550 (define-c-proc buffer-mode? (o) ::<boolean> :constant 1551 (result (or (SG_EQ o 'none) 1552 (SG_EQ o 'line) 1553 (SG_EQ o 'block)))) 1554 1555 ;; 8.2.4 transcoders 1556 (define-c-proc latin-1-codec () :no-side-effect Sg_MakeLatin1Codec) 1557 (define-c-proc utf-8-codec () :no-side-effect Sg_MakeUtf8Codec) 1558 (define-c-proc utf-16-codec () :no-side-effect 1559 (result (Sg_MakeUtf16Codec UTF_16CHECK_BOM))) 1560 1561 (define-c-proc native-eol-style () :no-side-effect 1562 (let ((style::SgEolStyle (Sg_NativeEol))) 1563 (cond ((== style LF) 1564 (result 'lf)) 1565 ((== style CR) 1566 (result 'cr)) 1567 ((== style LS) 1568 (result 'ls)) 1569 ((== style NEL) 1570 (result 'nel)) 1571 ((== style CRNEL) 1572 (result 'crnel)) 1573 ((== style CRLF) 1574 (result 'crlf)) 1575 ((== style E_NONE) 1576 (result 'none)) 1577 (else 1578 ;; all plat form should return eol style by Sg_NativeEol. 1579 ;; so this never happen. just dummy 1580 (assertion-violation 'native-eol-style 1581 "platform native eol style not found" 1582 '()))))) 1583 1584 (define-c-proc make-transcoder (c::<codec> :optional eol mode::<symbol>) 1585 :no-side-effect 1586 (unless (or (SG_UNBOUNDP eol) 1587 (SG_SYMBOLP eol)) 1588 (wrong-type-of-argument-violation 'make-transcoder 1589 "symbol" eol)) 1590 (let ((style::SgEolStyle (Sg_NativeEol)) 1591 (handling::SgErrorHandlingMode SG_REPLACE_ERROR)) 1592 (cond ((SG_UNBOUNDP eol)) ;; do nothing 1593 ((SG_EQ eol 'lf) 1594 (set! style LF)) 1595 ((SG_EQ eol 'cr) 1596 (set! style CR)) 1597 ((SG_EQ eol 'ls) 1598 (set! style LS)) 1599 ((SG_EQ eol 'nel) 1600 (set! style NEL)) 1601 ((SG_EQ eol 'crnel) 1602 (set! style CRNEL)) 1603 ((SG_EQ eol 'crlf) 1604 (set! style CRLF)) 1605 ((SG_EQ eol 'none) 1606 (set! style E_NONE)) 1607 (else 1608 (assertion-violation 'make-transcoder 1609 "invalid eol-style" 1610 eol))) 1611 (cond ((or (SG_UNBOUNDP mode) 1612 (SG_EQ mode 'replace))) ;; do nothing 1613 ((SG_EQ mode 'raise) 1614 (set! handling SG_RAISE_ERROR)) 1615 ((SG_EQ mode 'ignore) 1616 (set! handling SG_IGNORE_ERROR)) 1617 (else 1618 (assertion-violation 'make-transcoder 1619 "invalid error-handling-mode" 1620 mode))) 1621 (result (Sg_MakeTranscoder c style handling)))) 1622 1623 (define-c-proc native-transcoder () :no-side-effect Sg_MakeNativeTranscoder) 1624 1625 (define-c-proc transcoder-codec (t::<transcoder>) :no-side-effect 1626 SG_TRANSCODER_CODEC) 1627 1628 (define-c-proc transcoder-eol-style (t::<transcoder>) :no-side-effect 1629 (let ((style::SgEolStyle (SG_TRANSCODER_EOL_STYLE t))) 1630 (cond ((== style LF) 1631 (result 'lf)) 1632 ((== style CR) 1633 (result 'cr)) 1634 ((== style LS) 1635 (result 'ls)) 1636 ((== style NEL) 1637 (result 'nel)) 1638 ((== style CRNEL) 1639 (result 'crnel)) 1640 ((== style CRLF) 1641 (result 'crlf)) 1642 ((== style E_NONE) 1643 (result 'none)) 1644 (else 1645 ;; never happen 1646 (assertion-violation 'transcoder-eol-style 1647 "transcoder had unknown eol-style. this must be a bug, please report it" 1648 '()))))) 1649 1650 (define-c-proc transcoder-error-handling-mode (t::<transcoder>) 1651 :no-side-effect 1652 (let ((mode::SgErrorHandlingMode (SG_TRANSCODER_MODE t))) 1653 (cond ((SG_EQ mode SG_REPLACE_ERROR) 1654 (result SG_SYMBOL_REPLACE)) 1655 ((SG_EQ mode SG_IGNORE_ERROR) 1656 (result SG_SYMBOL_IGNORE)) 1657 ((SG_EQ mode SG_RAISE_ERROR) 1658 (result SG_SYMBOL_RAISE)) 1659 (else 1660 (assertion-violation 'transcoder-error-handling-mode 1661 "transcoder had unknown error-handling-mode. this must be a bug, please report it" 1662 '()))))) 1663 1664 (define-c-proc bytevector->string 1665 (b::<bytevector> t::<transcoder> 1666 :optional (start::<fixnum> 0) (end::<fixnum> -1)) 1667 :no-side-effect 1668 Sg_ByteVectorToString) 1669 1670 (define-c-proc string->bytevector 1671 (s::<string> t::<transcoder> 1672 :optional (start::<fixnum> 0) (end::<fixnum> -1)) 1673 :no-side-effect 1674 Sg_StringToByteVector) 1675 1676 ;; 8.2.5 end-of-file object 1677 (define-c-proc eof-object () :no-side-effect (result SG_EOF)) 1678 (define-c-proc eof-object? (o) ::<boolean> :constant SG_EOFP) 1679 1680 ;; 8.2.6 input port and output port 1681 ;; check utility for opened port 1682 (define-cise-stmt check-port-open 1683 ((_ name p) 1684 `(when (Sg_PortClosedP ,p) 1685 (wrong-type-of-argument-violation ',name "opened port" ,p)))) 1686 1687 (define-cise-stmt check-binary-port 1688 ((_ name p) 1689 `(unless (SG_BINARY_PORTP ,p) 1690 (wrong-type-of-argument-violation ',name "binary-port" ,p)))) 1691 1692 (define-c-proc port? (obj) ::<boolean> :constant SG_PORTP) 1693 1694 (define-c-proc port-transcoder (p::<port>) :no-side-effect 1695 Sg_PortTranscoder) 1696 1697 (define-c-proc textual-port? (p) ::<boolean> :constant SG_TEXTUAL_PORTP) 1698 1699 (define-c-proc binary-port? (p) ::<boolean> :constant SG_BINARY_PORTP) 1700 1701 (define-c-proc transcoded-port (p::<port> t::<transcoder>) 1702 (check-binary-port transcoded-port p) 1703 (check-port-open transcoded-port p) 1704 (Sg_PseudoClosePort p) 1705 (result (Sg_MakeTranscodedPort p t))) 1706 1707 (define-c-proc port-has-port-position? (p::<port>) ::<boolean> :no-side-effect 1708 Sg_HasPortPosition) 1709 1710 (define-c-proc port-has-set-port-position!? (p::<port>) ::<boolean> 1711 :no-side-effect 1712 Sg_HasSetPortPosition) 1713 1714 (define-c-proc port-position (p::<port>) :no-side-effect 1715 (check-port-open port-position p) 1716 (result (Sg_MakeIntegerFromS64 (Sg_PortPosition p)))) 1717 1718 (define-c-proc set-port-position! 1719 (p::<port> off::<number> :optional (whence::<symbol> 'begin)) 1720 ::<void> 1721 (check-port-open set-port-position! p) 1722 (let ((w::SgWhence SG_BEGIN)) 1723 (cond ((SG_EQ whence 'begin) 1724 (when (Sg_NegativeP off) 1725 (wrong-type-of-argument-violation 'set-port-position! 1726 "non negative number" 1727 off 1728 (SG_LIST3 p off whence))) 1729 (set! w SG_BEGIN)) 1730 ((SG_EQ whence 'current) (set! w SG_CURRENT)) 1731 ((SG_EQ whence 'end) (set! w SG_END)) 1732 (else (assertion-violation 'set-port-position! 1733 "unknown whence" whence))) 1734 (Sg_SetPortPosition p (Sg_GetIntegerS64Clamp off SG_CLAMP_NONE NULL) w))) 1735 1736 (define-c-proc close-port (p::<port>) ::<void> 1737 (Sg_ClosePort p)) 1738 1739 ;; 8.2.7 input port 1740 (define-cise-stmt check-input-port 1741 ((_ name p) 1742 `(unless (SG_INPUT_PORTP ,p) 1743 (wrong-type-of-argument-violation ',name "input port" ,p)))) 1744 1745 (define-c-proc input-port? (obj) ::<boolean> :constant SG_INPUT_PORTP) 1746 1747 (define-c-proc port-eof? (p::<port>) ::<boolean> :no-side-effect 1748 (if (SG_BINARY_PORTP p) 1749 (let ((ch::int (Sg_Peekb p))) 1750 (result (== ch EOF))) 1751 (let ((ch::SgChar (Sg_Peekc p))) 1752 (result (== ch EOF))))) 1753 1754 (define-c-proc open-file-input-port (file::<string> 1755 :optional (option #f) 1756 mode::<symbol> 1757 (transcoder::<transcoder> #f)) 1758 ;; we can ignore option 1759 (when (SG_UNBOUNDP mode) 1760 (set! mode 'block)) 1761 (let ((fo (Sg_OpenFile file SG_READ)) 1762 (bufferMode::int SG_BUFFER_MODE_BLOCK)) 1763 (unless (SG_FILEP fo) 1764 (Sg_IOError SG_IO_FILE_NOT_EXIST_ERROR 1765 'open-file-input-port fo file SG_UNDEF)) 1766 ;; we only support 'block or none for now. 1767 (if (SG_EQ mode 'none) 1768 (set! bufferMode SG_BUFFER_MODE_NONE)) 1769 (if (SG_FALSEP transcoder) 1770 (result (Sg_MakeFileBinaryInputPort fo bufferMode)) 1771 (let ((in (Sg_MakeFileBinaryInputPort fo bufferMode))) 1772 (result (Sg_MakeTranscodedPort in transcoder)))))) 1773 1774 (define-c-proc open-bytevector-input-port 1775 (bv::<bytevector> :optional (t::<transcoder> #f) 1776 (start::<fixnum> 0) (end::<fixnum> -1)) 1777 (let ((bp (Sg_MakeByteVectorInputPort bv start end))) 1778 (if (SG_FALSEP t) 1779 (result bp) 1780 (result (Sg_MakeTranscodedPort bp t))))) 1781 1782 (define-c-proc open-string-input-port 1783 (s::<string> :optional (start::<fixnum> 0) (end::<fixnum> -1)) 1784 (result (Sg_MakeStringInputPort s start end))) 1785 1786 (define-c-proc standard-input-port () Sg_StandardInputPort) 1787 1788 (define-c-proc current-input-port (:optional p::<port>) 1789 (let ((vm::SgVM* (Sg_VM))) 1790 (if (SG_UNBOUNDP p) 1791 (result (-> vm currentInputPort)) 1792 (begin 1793 (check-input-port current-input-port p) 1794 (set! (-> vm currentInputPort) p) 1795 (result SG_UNDEF))))) 1796 1797 (define-cise-stmt check-procedure-or-false 1798 ((_ name proc) 1799 `(unless (or (SG_FALSEP ,proc) 1800 (SG_PROCEDUREP ,proc)) 1801 (wrong-type-of-argument-violation ',name 1802 "procedure or #f" 1803 ,proc)))) 1804 1805 (define-c-proc make-custom-binary-input-port 1806 (id::<string> read::<procedure> getter setter close 1807 :optional (ready #f)) 1808 (check-procedure-or-false make-custom-binary-input-port getter) 1809 (check-procedure-or-false make-custom-binary-input-port setter) 1810 (check-procedure-or-false make-custom-binary-input-port close) 1811 (check-procedure-or-false make-custom-binary-input-port ready) 1812 (result (Sg_MakeCustomBinaryPort id SG_INPUT_PORT read SG_FALSE 1813 getter setter close ready))) 1814 1815 (define-c-proc make-custom-textual-input-port 1816 (id::<string> read::<procedure> getter setter close 1817 :optional (ready #f)) 1818 (check-procedure-or-false make-custom-textual-input-port getter) 1819 (check-procedure-or-false make-custom-textual-input-port setter) 1820 (check-procedure-or-false make-custom-textual-input-port close) 1821 (check-procedure-or-false make-custom-textual-input-port ready) 1822 (result (Sg_MakeCustomTextualPort id SG_INPUT_PORT read SG_FALSE 1823 getter setter close ready))) 1824 1825 ;; 8.2.8 binary input 1826 (decl-code (.include <string.h>)) 1827 1828 ;; we don't know what would happen in custom port 1829 ;; so if it's custom port we lock it. 1830 (define-cise-stmt binary-port-read-u8-op 1831 ((_ p safe) 1832 (let ((unsafe (string->symbol (format "~aUnsafe" safe)))) 1833 `(let ((b::int)) 1834 (if (SG_CUSTOM_PORTP ,p) 1835 (set! b (,safe ,p)) 1836 (set! b (,unsafe ,p))) 1837 (if (== EOF b) 1838 (result SG_EOF) 1839 (result (SG_MAKE_INT b))))))) 1840 (define-cise-stmt binary-port-write-u8-op 1841 ((_ p b safe) 1842 (let ((unsafe (string->symbol (format "~aUnsafe" safe)))) 1843 `(if (SG_CUSTOM_PORTP ,p) 1844 (,safe ,p ,b) 1845 (,unsafe ,p ,b))))) 1846 1847 (define-c-proc get-u8 (p::<port> :optional (reckless #f)) 1848 (check-port-open get-u8 p) 1849 (when (SG_FALSEP reckless) (check-binary-port get-u8 p)) 1850 (check-input-port get-u8 p) 1851 (binary-port-read-u8-op p Sg_Getb)) 1852 1853 (define-c-proc lookahead-u8 (p::<port> :optional (reckless #f)) 1854 (check-port-open lookahead-u8 p) 1855 (when (SG_FALSEP reckless) (check-binary-port lookahead-u8 p)) 1856 (check-input-port lookahead-u8 p) 1857 (binary-port-read-u8-op p Sg_Peekb)) 1858 1859 (define-cise-stmt check-fixnum-range 1860 ((_ name t start end start-op end-op) 1861 `(unless (and (,start-op ,start ,t) 1862 (,end-op ,t ,end)) 1863 (assertion-violation ',name "out of range" (SG_MAKE_INT ,t)))) 1864 ((_ name t range op) 1865 `(unless (,op ,t ,range) 1866 (assertion-violation ',name "out of range" (SG_MAKE_INT ,t))))) 1867 1868 (define-cise-stmt read-to-buffer 1869 ((_ port result buf start count read) 1870 (let ((i (gensym)) 1871 (r (gensym)) 1872 (c (gensym)) 1873 (t (gensym))) 1874 `(let ((,(string->symbol (format "~a::int64_t" i)) ,start) 1875 (,(string->symbol (format "~a::int64_t" r)) 0) 1876 (,(string->symbol (format "~a::int64_t" c)) ,count) 1877 (,(string->symbol (format "~a::int" t)) (Sg_ReadOncePortP ,port))) 1878 (for (() (not (== ,c 0)) ()) 1879 (set! ,r (,read ,port (+ ,buf ,i) ,c)) 1880 (set! ,result (+ ,r ,result)) 1881 ;; (when (< ,r ,c) (break)) 1882 (when (== ,r 0) (break)) 1883 (when ,t (break)) 1884 (set! ,c (- ,c ,r)) 1885 (set! ,i (+ ,i ,r))))))) 1886 1887 (define-c-proc get-bytevector-n 1888 (p::<port> count::<fixnum> :optional (reckless #f)) 1889 (check-port-open get-bytevector-n p) 1890 (when (SG_FALSEP reckless) (check-binary-port get-bytevector-n p)) 1891 (check-input-port get-bytevector-n p) 1892 (check-non-negative-fixnum get-bytevector-n count) 1893 (if (== count 0) 1894 (result (Sg_MakeByteVector 0 0)) 1895 (let ((buf (Sg_MakeByteVector count 0)) 1896 (res::int64_t 0)) 1897 ;; (Sg_Readb p (SG_BVECTOR_ELEMENTS buf) count) 1898 (SG_PORT_LOCK_READ p) 1899 (read-to-buffer p res (SG_BVECTOR_ELEMENTS buf) 1900 0 count Sg_ReadbUnsafe) 1901 (SG_PORT_UNLOCK_READ p) 1902 (cond ((== res 0) (result SG_EOF)) 1903 (else 1904 (unless (== count res) 1905 (set! (SG_BVECTOR_SIZE buf) res)) 1906 (result buf)))))) 1907 1908 (define-c-proc get-bytevector-n! 1909 (p::<port> bv::<bytevector> start::<fixnum> count::<fixnum> 1910 :optional (reckless #f)) 1911 (check-port-open get-bytevector-n! p) 1912 (when (SG_FALSEP reckless) (check-binary-port get-bytevector-n p)) 1913 (check-input-port get-bytevector-n! p) 1914 (check-non-negative-fixnum get-bytevector-n! start) 1915 (check-non-negative-fixnum get-bytevector-n! count) 1916 (check-fixnum-range get-bytevector-n! (SG_BVECTOR_SIZE bv)(+ start count)>=) 1917 (if (== count 0) 1918 (result (SG_MAKE_INT 0)) 1919 (let ((res::int64_t 0)) 1920 ;; (Sg_Readb p (+ (SG_BVECTOR_ELEMENTS bv) start) count) 1921 (SG_PORT_LOCK_READ p) 1922 (read-to-buffer p res (SG_BVECTOR_ELEMENTS bv) 1923 start count Sg_ReadbUnsafe) 1924 (SG_PORT_UNLOCK_READ p) 1925 (if (== res 0) 1926 (result SG_EOF) 1927 (result (SG_MAKE_INT res)))))) 1928 1929 ;; TODO this allocates memory twice. 1930 (define-c-proc get-bytevector-some (p::<port> :optional (reckless #f)) 1931 (check-port-open get-bytevector-some p) 1932 (when (SG_FALSEP reckless) 1933 (check-binary-port get-bytevector-n p)) 1934 (check-input-port get-bytevector-some p) 1935 (let ((buf (Sg_MakeByteVector 512 0)) ;; some 1936 (res::int64_t 0)) 1937 ;; (Sg_Readb p (SG_BVECTOR_ELEMENTS buf) 512) 1938 (SG_PORT_LOCK_READ p) 1939 (read-to-buffer p res (SG_BVECTOR_ELEMENTS buf) 0 512 Sg_ReadbUnsafe) 1940 (SG_PORT_UNLOCK_READ p) 1941 (cond ((== res 0) 1942 (result SG_EOF)) 1943 (else 1944 (unless (== res 512) 1945 (set! (SG_BVECTOR_SIZE buf) res)) 1946 (result buf))))) 1947 1948 (define-c-proc get-bytevector-all (p::<port> :optional (reckless #f)) 1949 (check-port-open get-bytevector-all p) 1950 (when (SG_FALSEP reckless) 1951 (check-binary-port get-bytevector-n p)) 1952 (check-input-port get-bytevector-all p) 1953 ;; TODO we need to get the rest size to reduce memory allocation. 1954 ;; but for now I implement like this 1955 (let ((buf::uint8_t* NULL) 1956 (res::int64_t (Sg_ReadbAll p (& buf)))) 1957 (if (== res 0) 1958 (result SG_EOF) 1959 (let ((r (Sg_MakeByteVectorFromU8Array buf res))) 1960 (set! buf NULL) ; gc friendliness 1961 (result r))))) 1962 1963 ;; 8.2.9 textual port 1964 (define-cise-stmt check-textual-port 1965 ((_ name p) 1966 `(unless (SG_TEXTUAL_PORTP ,p) 1967 (wrong-type-of-argument-violation ',name 1968 "textual-port" 1969 ,p)))) 1970 1971 (define-cise-expr string-port? 1972 ((_ p) 1973 `(SG_STRING_PORTP ,p))) 1974 ;; If it's transcoded port there is always a chance to read more then 1975 ;; one byte and if that happens in multi thread script it would not 1976 ;; read a char properly. in case of the we need lock 1977 ;; custom port is the same reason as binary port. 1978 ;; so only string port which is buffering and it always put one char 1979 ;; in one operation. 1980 (define-cise-stmt string-port-read-char-op 1981 ((_ p safe) 1982 (let ((unsafe (string->symbol (format "~aUnsafe" safe)))) 1983 `(let ((c::SgChar)) 1984 (if (string-port? ,p) 1985 (set! c (,unsafe ,p)) 1986 (set! c (,safe ,p))) 1987 (if (== c EOF) 1988 (result SG_EOF) 1989 (result (SG_MAKE_CHAR c))))))) 1990 (define-cise-stmt string-port-write-char-op 1991 ((_ p c safe) 1992 (let ((unsafe (string->symbol (format "~aUnsafe" safe)))) 1993 `(if (string-port? ,p) 1994 (,unsafe ,p ,c) 1995 (,safe ,p ,c))))) 1996 1997 (define-c-proc get-char (p::<port>) 1998 (check-port-open get-char p) 1999 (check-textual-port get-char p) 2000 (check-input-port get-char p) 2001 (string-port-read-char-op p Sg_Getc)) 2002 2003 (define-c-proc lookahead-char (p::<port>) 2004 (check-port-open lookahead-char p) 2005 (check-textual-port lookahead-char p) 2006 (check-input-port lookahead-char p) 2007 (string-port-read-char-op p Sg_Peekc)) 2008 2009 (define-c-proc get-string-n (p::<port> count::<fixnum>) 2010 (check-port-open get-string-n p) 2011 (check-textual-port get-string-n p) 2012 (check-input-port get-string-n p) 2013 (check-non-negative-fixnum get-string-n count) 2014 (if (== count 0) 2015 (result (Sg_MakeEmptyString)) 2016 (let ((ch::SgChar (Sg_Peekc p))) 2017 (if (== ch EOF) 2018 (result SG_EOF) 2019 (let* ((buf::SgString* (Sg_ReserveString count 0)) 2020 (len::int64_t 0)) 2021 ;; (Sg_Reads p (SG_STRING_VALUE buf) count) 2022 (SG_PORT_LOCK_READ p) 2023 (read-to-buffer p len (SG_STRING_VALUE buf) 0 count 2024 Sg_ReadsUnsafe) 2025 (SG_PORT_UNLOCK_READ p) 2026 (if (== len count) 2027 (result buf) 2028 (result (Sg_Substring buf 0 len)))))))) 2029 2030 (define-c-proc get-string-n! 2031 (p::<port> s::<string> start::<fixnum> count::<fixnum>) 2032 2033 (check-port-open get-string-n! p) 2034 (check-textual-port get-string-n! p) 2035 (check-input-port get-string-n! p) 2036 (check-non-negative-fixnum get-string-n! start) 2037 (check-non-negative-fixnum get-string-n! count) 2038 (check-fixnum-range get-string-n! (SG_STRING_SIZE s) (+ start count) >=) 2039 ;; string must not be literal 2040 (when (SG_IMMUTABLE_STRINGP s) 2041 (assertion-violation 'get-string-n! 2042 "attempt to modify an immutable string" s)) 2043 (if (== count 0) 2044 (result (SG_MAKE_INT 0)) 2045 (let ((ch::SgChar (Sg_Peekc p))) 2046 (if (== ch EOF) 2047 (result SG_EOF) 2048 (let ((len::int64_t 0)) 2049 ;; (Sg_Reads p (+ (SG_STRING_VALUE s) start) count) 2050 (SG_PORT_LOCK_READ p) 2051 (read-to-buffer p len (SG_STRING_VALUE s) start count 2052 Sg_ReadsUnsafe) 2053 (SG_PORT_UNLOCK_READ p) 2054 (result (SG_MAKE_INT len))))))) 2055 2056 (define-c-proc get-string-all (p::<port>) 2057 (check-port-open get-string-all p) 2058 (check-textual-port get-string-all p) 2059 (check-input-port get-string-all p) 2060 (let ((ch::SgChar (Sg_Peekc p))) 2061 (cond ((== ch EOF) 2062 (result SG_EOF)) 2063 (else 2064 (SG_PORT_LOCK_READ p) 2065 ;; TODO how much should we allocate as default size? 2066 (let ((buf (Sg_ReserveString 1024 0)) 2067 (out SG_FALSE) 2068 (firstP::int TRUE)) ;; to avoid unnecessary allocation 2069 (loop 2070 (let ((len::int64_t 2071 (Sg_ReadsUnsafe p (SG_STRING_VALUE buf) 1024))) 2072 ;; ok if len is less, then read everything 2073 (cond ((== len 0) 2074 (when firstP 2075 (SG_PORT_UNLOCK_READ p) 2076 (return SG_EOF)) 2077 (break)) 2078 ((< len 1024) 2079 (when firstP 2080 (SG_PORT_UNLOCK_READ p) 2081 (return (Sg_Substring buf 0 len))) 2082 (Sg_Writes out (SG_STRING_VALUE buf) len) 2083 (break)) 2084 (else 2085 (if firstP (set! out (Sg_MakeStringOutputPort -1))) 2086 (Sg_PutsUnsafe out buf))) 2087 (set! firstP FALSE))) 2088 (SG_PORT_UNLOCK_READ p) 2089 (result (Sg_GetStringFromStringPort out))))))) 2090 2091 (define-c-proc get-line (p::<port>) 2092 (check-port-open get-line p) 2093 (check-textual-port get-line p) 2094 (check-input-port get-line p) 2095 (result (Sg_ReadLine p LF))) 2096 2097 (define-c-proc get-datum (p::<port>) 2098 (check-port-open get-dutum p) 2099 (check-textual-port get-datum p) 2100 (check-input-port get-dutum p) 2101 ;; TODO should get-datum read shared-object too? 2102 (let ((ctx::SgReadContext SG_STATIC_READ_CONTEXT)) 2103 (result (Sg_ReadWithContext p (& ctx))))) 2104 2105 ;; 8.2.10 output port 2106 (define-cise-stmt check-output-port 2107 ((_ name p) 2108 `(unless (SG_OUTPUT_PORTP ,p) 2109 (wrong-type-of-argument-violation ',name "output port" ,p)))) 2110 2111 (define-c-proc output-port? (obj) ::<boolean> :constant SG_OUTPUT_PORTP) 2112 2113 (define-c-proc flush-output-port 2114 (:optional (p::<port> (Sg_CurrentOutputPort))) ::<void> 2115 Sg_FlushPort) 2116 2117 (define-c-proc output-port-buffer-mode (p::<port>) 2118 (if (SG_BUFFERED_PORTP p) 2119 (cond ((SG_EQ (-> (SG_BUFFERED_PORT p) mode) SG_BUFFER_MODE_NONE) 2120 (result 'none)) 2121 ((SG_EQ (-> (SG_BUFFERED_PORT p) mode) SG_BUFFER_MODE_LINE) 2122 (result 'line)) 2123 ((SG_EQ (-> (SG_BUFFERED_PORT p) mode) SG_BUFFER_MODE_BLOCK) 2124 (result 'block)) 2125 (else 2126 (assertion-violation 'output-port-buffer-mode 2127 "port has invalid buffer mode. may be bug?" 2128 p))) 2129 (result 'none))) 2130 2131 (define-cfn get-open-flags 2132 (option oflags::int file exists?::int rappend::int*) 2133 ::int :static 2134 (let ((opt (Sg_SlotRefUsingClass (Sg_ClassOf option) option 'members))) 2135 (if (and exists? (SG_NULLP opt)) 2136 (throw-i/o-error SG_IO_FILE_ALREADY_EXIST_ERROR 2137 'open-file-output-port 2138 "file already exists" file 0) 2139 (let ((no-create?::int (not (SG_FALSEP (Sg_Memq 'no-create opt)))) 2140 (no-truncate?::int (not (SG_FALSEP (Sg_Memq 'no-truncate opt)))) 2141 (no-fail?::int (not (SG_FALSEP (Sg_Memq 'no-fail opt)))) 2142 (append?::int (not (SG_FALSEP (Sg_Memq 'append opt)))) 2143 (open-flags::int oflags)) 2144 (cond ((and no-create? no-truncate?) 2145 (when (not exists?) 2146 (throw-i/o-error SG_IO_FILE_NOT_EXIST_ERROR 2147 'open-file-output-port 2148 "file-options no-create: file not exist" 2149 file 0))) 2150 (no-create? 2151 (if exists? 2152 (set! open-flags (logior SG_TRUNCATE open-flags)) 2153 (throw-i/o-error SG_IO_FILE_NOT_EXIST_ERROR 2154 'open-file-output-port 2155 "file-options no-create: file not exist" 2156 file 0))) 2157 ((and no-fail? no-truncate?) 2158 (when (not exists?) 2159 (set! open-flags (logior SG_TRUNCATE open-flags)))) 2160 (no-fail? 2161 ;; no-truncate 2162 (set! open-flags (logior SG_TRUNCATE open-flags))) 2163 (no-truncate? 2164 (cond ((and exists? (not append?)) 2165 (throw-i/o-error SG_IO_FILE_ALREADY_EXIST_ERROR 2166 'open-file-output-port 2167 "file-options no-truncate: file already exist" 2168 file 0)) 2169 ((not append?) 2170 (set! open-flags (logior SG_TRUNCATE open-flags)))))) 2171 (when append? (set! (pointer rappend) append?)) 2172 (return open-flags))) 2173 ;; dummy 2174 (return 0))) 2175 2176 (define-c-proc open-file-output-port (file::<string> 2177 :optional (option #f) 2178 mode::<symbol> 2179 (transcoder::<transcoder> #f)) 2180 (when (SG_UNBOUNDP mode) (set! mode 'block)) 2181 (let ((fo SG_UNDEF) 2182 (isFileExist::int (Sg_FileExistP file)) 2183 (openFlags::int (logior SG_WRITE SG_CREATE)) 2184 (bufferMode::int SG_BUFFER_MODE_BLOCK)) 2185 (cond ((SG_EQ mode 'none) 2186 (set! bufferMode SG_BUFFER_MODE_NONE)) 2187 ((SG_EQ mode 'line) 2188 (set! bufferMode SG_BUFFER_MODE_LINE))) 2189 (cond ((SG_FALSEP option) 2190 (if isFileExist 2191 (throw-i/o-error SG_IO_FILE_ALREADY_EXIST_ERROR 2192 'open-file-output-port "file already exists" 2193 file)) 2194 (set! fo (Sg_OpenFile file openFlags)) 2195 (unless (SG_FILEP fo) 2196 (Sg_IOError SG_IO_FILE_NOT_EXIST_ERROR 2197 'open-file-output-port 2198 fo file SG_UNDEF)) 2199 (result (Sg_MakeFileBinaryOutputPort fo bufferMode))) 2200 (else 2201 ;; this is basically depending on the non-compiled Scheme code 2202 ;; not so good... 2203 (unless (Sg_RecordP option) 2204 (assertion-violation 'open-file-output-port 2205 "invalid file options" option)) 2206 (let ((append?::int 0)) 2207 (set! openFlags (get-open-flags option openFlags 2208 file isFileExist (& append?))) 2209 (set! fo (Sg_OpenFile file openFlags)) 2210 (unless (SG_FILEP fo) 2211 (Sg_IOError SG_IO_FILE_NOT_EXIST_ERROR 2212 'open-file-output-port fo file SG_UNDEF)) 2213 (when append? (Sg_FileSeek fo 0 SG_END)) 2214 (if (SG_FALSEP transcoder) 2215 (result (Sg_MakeFileBinaryOutputPort fo bufferMode)) 2216 (let ((out (Sg_MakeFileBinaryOutputPort fo bufferMode))) 2217 (result (Sg_MakeTranscodedPort out transcoder))))))))) 2218 2219 (define-c-proc standard-output-port () Sg_StandardOutputPort) 2220 2221 (define-c-proc standard-error-port () Sg_StandardErrorPort) 2222 2223 (define-c-proc current-output-port (:optional p) 2224 (let ((vm::SgVM* (Sg_VM))) 2225 (if (SG_UNBOUNDP p) 2226 (result (-> vm currentOutputPort)) 2227 (begin 2228 (check-output-port current-output-port p) 2229 (set! (-> vm currentOutputPort) p) 2230 (result SG_UNDEF))))) 2231 2232 (define-c-proc current-error-port (:optional p) 2233 (let ((vm::SgVM* (Sg_VM))) 2234 (if (SG_UNBOUNDP p) 2235 (result (-> vm currentErrorPort)) 2236 (begin 2237 (check-output-port current-error-port p) 2238 (set! (-> vm currentErrorPort) p) 2239 (result SG_UNDEF))))) 2240 2241 (define-c-proc make-custom-binary-output-port 2242 (id::<string> write::<procedure> getter setter close) 2243 (check-procedure-or-false make-custom-binary-output-port getter) 2244 (check-procedure-or-false make-custom-binary-output-port setter) 2245 (check-procedure-or-false make-custom-binary-output-port close) 2246 (result (Sg_MakeCustomBinaryPort id SG_OUTPUT_PORT SG_FALSE write 2247 getter setter close SG_FALSE))) 2248 2249 (define-c-proc make-custom-textual-output-port 2250 (id::<string> write::<procedure> getter setter close) 2251 (check-procedure-or-false make-custom-textual-output-port getter) 2252 (check-procedure-or-false make-custom-textual-output-port setter) 2253 (check-procedure-or-false make-custom-textual-output-port close) 2254 (result (Sg_MakeCustomTextualPort id SG_OUTPUT_PORT SG_FALSE write 2255 getter setter close SG_FALSE))) 2256 2257 ;; 8.2.11 binary output 2258 (define-c-proc put-u8 (p::<port> octet::<fixnum> :optional (reckless #f)) 2259 ::<void> 2260 (check-port-open put-u8 p) 2261 (when (SG_FALSEP reckless) 2262 (check-binary-port put-u8 p)) 2263 (check-output-port put-u8 p) 2264 (check-fixnum-range put-u8 octet 0 255 <= <=) 2265 (binary-port-write-u8-op p octet Sg_Putb)) 2266 2267 (define-c-proc put-bytevector 2268 (p::<port> bv::<bytevector> 2269 :optional (start::<fixnum> 0) 2270 (count::<fixnum> (SG_MAKE_INT (- (SG_BVECTOR_SIZE bv) start))) 2271 (reckless #f)) 2272 ::<void> 2273 (check-port-open put-bytevector p) 2274 (when (SG_FALSEP reckless) 2275 (check-binary-port put-bytevector p)) 2276 (check-output-port put-bytevector p) 2277 (check-non-negative-fixnum put-bytevector start) 2278 (check-non-negative-fixnum put-bytevector count) 2279 (unless (<= (+ count start) (SG_BVECTOR_SIZE bv)) 2280 (assertion-violation 'put-bytevector 2281 "invalid range")) 2282 (Sg_Writeb p (SG_BVECTOR_ELEMENTS bv) start count)) 2283 2284 ;; 8.2.13 textual output 2285 (define-c-proc put-char (p::<port> ch::<char>) ::<void> 2286 (check-port-open put-char p) 2287 (check-output-port put-char p) 2288 (check-textual-port put-char p) 2289 (string-port-write-char-op p ch Sg_Putc)) 2290 2291 (define-c-proc put-string 2292 (p::<port> s::<string> 2293 :optional (start::<fixnum> 0) 2294 (count::<fixnum> (SG_MAKE_INT (- (SG_STRING_SIZE s) start)))) 2295 ::<void> 2296 (check-port-open put-string p) 2297 (check-output-port put-string p) 2298 (check-textual-port put-string p) 2299 (check-non-negative-fixnum put-string start) 2300 (check-non-negative-fixnum put-string count) 2301 (unless (<= (+ count start) (SG_STRING_SIZE s)) 2302 (assertion-violation 'put-string "invalid range")) 2303 (Sg_Writes p (+ (SG_STRING_VALUE s) start) count)) 2304 2305 (define-c-proc put-datum (p::<port> datum) ::<void> 2306 (check-port-open put-datum p) 2307 (check-output-port put-datum p) 2308 (check-textual-port put-datum p) 2309 (Sg_Write datum p SG_WRITE_WRITE)) 2310 2311 ;; 8.2.13 input output ports 2312 (define-c-proc open-file-input/output-port 2313 (file::<string> :optional (option #f) 2314 mode::<symbol> 2315 (transcoder::<transcoder> #f)) 2316 (when (SG_UNBOUNDP mode) 2317 (set! mode 'block)) 2318 (let ((fo SG_UNDEF) 2319 (isFileExist::int (Sg_FileExistP file)) 2320 (openFlags::int (logior SG_READ (logior SG_WRITE SG_CREATE))) 2321 (bufferMode::int SG_BUFFER_MODE_BLOCK)) 2322 (cond ((SG_EQ mode 'none) 2323 (set! bufferMode SG_BUFFER_MODE_NONE)) 2324 ((SG_EQ mode 'line) 2325 (set! bufferMode SG_BUFFER_MODE_LINE))) 2326 (cond ((SG_FALSEP option) 2327 (if isFileExist 2328 (throw-i/o-error SG_IO_FILE_ALREADY_EXIST_ERROR 2329 'open-file-input/output-port 2330 "file already exists" file)) 2331 (set! fo (Sg_OpenFile file openFlags)) 2332 (unless (SG_FILEP fo) 2333 (Sg_IOError SG_IO_FILE_NOT_EXIST_ERROR 2334 'open-file-input/output-port fo file SG_UNDEF)) 2335 (result (Sg_MakeFileBinaryInputOutputPort fo bufferMode))) 2336 (else 2337 (unless (Sg_RecordP option) 2338 (assertion-violation 'open-file-output-port 2339 "invalid file options" option)) 2340 (let ((append?::int 0)) 2341 (set! openFlags (get-open-flags option openFlags 2342 file isFileExist (& append?))) 2343 (set! fo (Sg_OpenFile file openFlags)) 2344 (unless (SG_FILEP fo) 2345 (Sg_IOError SG_IO_FILE_NOT_EXIST_ERROR 2346 'open-file-input/output-port fo file SG_UNDEF)) 2347 (when append? (Sg_FileSeek fo 0 SG_END)) 2348 (if (SG_FALSEP transcoder) 2349 (result (Sg_MakeFileBinaryInputOutputPort fo bufferMode)) 2350 (let ((out (Sg_MakeFileBinaryInputOutputPort fo bufferMode))) 2351 (result (Sg_MakeTranscodedPort out transcoder))))))))) 2352 2353 (define-c-proc make-custom-binary-input/output-port 2354 (id::<string> read::<procedure> write::<procedure> getter setter close 2355 :optional (ready #f)) 2356 (check-procedure-or-false make-custom-binary-input/output-port getter) 2357 (check-procedure-or-false make-custom-binary-input/output-port setter) 2358 (check-procedure-or-false make-custom-binary-input/output-port close) 2359 (check-procedure-or-false make-custom-binary-input/output-port ready) 2360 (result (Sg_MakeCustomBinaryPort id SG_IN_OUT_PORT read write 2361 getter setter close ready))) 2362 2363 (define-c-proc make-custom-textual-input/output-port 2364 (id::<string> read::<procedure> write::<procedure> getter setter close 2365 :optional (ready #f)) 2366 (check-procedure-or-false make-custom-textual-input/output-port getter) 2367 (check-procedure-or-false make-custom-textual-input/output-port setter) 2368 (check-procedure-or-false make-custom-textual-input/output-port close) 2369 (check-procedure-or-false make-custom-textual-input/output-port ready) 2370 (result (Sg_MakeCustomTextualPort id SG_IN_OUT_PORT read write 2371 getter setter close ready))) 2372 2373 ;; 8.3 simple i/o 2374 (define-c-proc close-input-port (p::<port>) ::<void> 2375 (unless (SG_INPUT_PORTP p) 2376 (wrong-type-of-argument-violation 'close-input-port "input port" p)) 2377 (Sg_ClosePort p)) 2378 2379 (define-c-proc close-output-port (p::<port>) ::<void> 2380 (unless (SG_OUTPUT_PORTP p) 2381 (wrong-type-of-argument-violation 'close-output-port "output port" p)) 2382 (Sg_ClosePort p)) 2383 2384 (define-c-proc read-char (:optional (p::<port> (Sg_CurrentInputPort))) 2385 (check-port-open read-char p) 2386 (check-input-port read-char p) 2387 (check-textual-port read-char p) 2388 (string-port-read-char-op p Sg_Getc)) 2389 2390 (define-c-proc peek-char (:optional (p::<port> (Sg_CurrentInputPort))) 2391 (check-port-open peek-char p) 2392 (check-input-port peek-char p) 2393 (check-textual-port peek-char p) 2394 (string-port-read-char-op p Sg_Peekc)) 2395 2396 (define-c-proc read (:optional (p::<port> (Sg_CurrentInputPort)) 2397 :key (source-info?::<boolean> #f) 2398 (read-shared?::<boolean> #f)) 2399 (check-port-open read p) 2400 (check-input-port read p) 2401 (let ((ctx::SgReadContext SG_STATIC_READ_CONTEXT)) 2402 (when source-info? 2403 (set! (ref ctx flags) SG_READ_SOURCE_INFO)) 2404 (when read-shared? 2405 (set! (ref ctx graph) (Sg_MakeHashTableSimple SG_HASH_EQ 1))) 2406 (result (Sg_ReadWithContext p (& ctx))))) 2407 2408 (define-c-proc write-char (ch::<char> :optional 2409 (p::<port> (Sg_CurrentOutputPort))) 2410 ::<void> 2411 (check-port-open write-char p) 2412 (check-output-port write-char p) 2413 (check-textual-port write-char p) 2414 (string-port-write-char-op p ch Sg_Putc)) 2415 2416 (define-c-proc newline (:optional (p::<port> (Sg_CurrentOutputPort))) ::<void> 2417 (check-port-open newline p) 2418 (check-output-port newline p) 2419 (check-textual-port newline p) 2420 (string-port-write-char-op p #\linefeed Sg_Putc)) 2421 2422 (define-c-proc display (o :optional (p::<port> (Sg_CurrentOutputPort))) ::<void> 2423 (check-port-open display p) 2424 (check-output-port display p) 2425 (Sg_Write o p SG_WRITE_DISPLAY)) 2426 2427 (define-c-proc write (o :optional (p::<port> (Sg_CurrentOutputPort))) ::<void> 2428 (check-port-open write p) 2429 (check-output-port write p) 2430 (Sg_Write o p SG_WRITE_WRITE)) 2431 2432 ;; 9 file system 2433 ;; the same string can return the different value... 2434 (define-c-proc file-exists? (filename::<string>) ::<boolean> :no-side-effect 2435 Sg_FileExistP) 2436 2437 (define-c-proc delete-file (filename::<string>) ::<void> 2438 (let ((r::int (Sg_DeleteFile filename))) 2439 (unless (== r 0) 2440 (Sg_IOError SG_IO_FILENAME_ERROR 'delete-file 2441 (Sg_GetLastErrorMessageWithErrorCode r) 2442 filename SG_UNDEF)))) 2443 2444 (define-c-proc exit (:optional obj) ::<void> 2445 ;; TODO thread 2446 (if (SG_UNBOUNDP obj) 2447 (Sg_Exit EXIT_SUCCESS) 2448 (cond ((SG_INTP obj) (Sg_Exit (cast int (SG_INT_VALUE obj)))) 2449 ((SG_TRUEP obj) (Sg_Exit EXIT_SUCCESS)) 2450 (else (Sg_Exit EXIT_FAILURE))))) 2451 2452 ;; 11 Arithmetic 2453 ;; 11.2 fixnum (moved to fixnums.stub) 2454 ;; 11.3 flonums (moved to flonums.stub) 2455 2456 ;; 11.4 exact bitwise arithmetic 2457 (define-c-proc bitwise-not (ei::<number>) :constant 2458 (unless (Sg_ExactP ei) 2459 (wrong-type-of-argument-violation 'bitwise-not "exact integer required" ei)) 2460 (result (Sg_LogNot ei))) 2461 2462 (define-cise-stmt logop 2463 ((_ fn x y rest) 2464 `(let ((r (,fn ,x ,y))) 2465 (for-each (lambda (v) (set! r (,fn r v))) ,rest) 2466 (result r)))) 2467 2468 (define-c-proc bitwise-and 2469 (:optional ei::<integer> ei2::<integer> :rest rest) :constant 2470 (cond ((SG_UNBOUNDP ei) (result (SG_MAKE_INT -1))) 2471 ((SG_NULLP rest) 2472 (if (SG_UNBOUNDP ei2) 2473 (result ei) 2474 (result (Sg_LogAnd ei ei2)))) 2475 (else 2476 (set! ei (Sg_LogAnd ei ei2)) 2477 (logop Sg_LogAnd ei (SG_CAR rest) (SG_CDR rest))))) 2478 2479 (define-c-proc bitwise-ior 2480 (:optional ei::<integer> ei2::<integer> :rest rest) :constant 2481 (cond ((SG_UNBOUNDP ei) (result (SG_MAKE_INT 0))) 2482 ((SG_NULLP rest) 2483 (if (SG_UNBOUNDP ei2) 2484 (result ei) 2485 (result (Sg_LogIor ei ei2)))) 2486 (else 2487 (set! ei (Sg_LogIor ei ei2)) 2488 (logop Sg_LogIor ei (SG_CAR rest) (SG_CDR rest))))) 2489 2490 (define-c-proc bitwise-xor 2491 (:optional ei::<integer> ei2::<integer> :rest rest) :constant 2492 (cond ((SG_UNBOUNDP ei) (result (SG_MAKE_INT 0))) 2493 ((SG_NULLP rest) 2494 (if (SG_UNBOUNDP ei2) 2495 (result ei) 2496 (result (Sg_LogXor ei ei2)))) 2497 (else 2498 (set! ei (Sg_LogXor ei ei2)) 2499 (logop Sg_LogXor ei (SG_CAR rest) (SG_CDR rest))))) 2500 2501 (define-cise-expr logif 2502 ((_ n1 n2 n3) 2503 `(Sg_LogIor (Sg_LogAnd ,n1 ,n2) 2504 (Sg_LogAnd (Sg_LogNot ,n1) ,n3)))) 2505 2506 (define-c-proc bitwise-if (ei1::<number> ei2::<number> ei3::<number>) 2507 :constant 2508 (result (logif ei1 ei2 ei3))) 2509 2510 (define-c-proc bitwise-bit-count (ei::<number>) ::<fixnum> :constant 2511 Sg_BitCount) 2512 2513 (define-c-proc bitwise-length (ei::<number>) ::<fixnum> :constant 2514 Sg_BitSize) 2515 2516 (define-c-proc bitwise-first-bit-set (ei::<number>) ::<fixnum> :constant 2517 Sg_FirstBitSet) 2518 2519 (define-c-proc bitwise-bit-set? (ei1::<number> ei2::<fixnum>) 2520 ::<boolean> :constant 2521 Sg_BitSetP) 2522 2523 (define-c-proc bitwise-copy-bit (ei1::<number> ei2::<fixnum> ei3::<number>) 2524 :constant 2525 (let ((mask (Sg_Ash (SG_MAKE_INT 1) ei2))) 2526 (result (logif mask (Sg_Ash ei3 ei2) ei1)))) 2527 2528 (define-c-proc bitwise-bit-field (ei1::<number> ei2::<fixnum> ei3::<fixnum>) 2529 :constant 2530 (when (< ei2 0) 2531 (assertion-violation 'bitwise-bit-field 2532 "2nd parameter (start) must be non-negative" (SG_MAKE_INT ei2))) 2533 (when (< ei3 0) 2534 (assertion-violation 'bitwise-bit-field 2535 "3rd parameter (end) must be non-negative" (SG_MAKE_INT ei3))) 2536 (when (> ei2 ei3) 2537 (assertion-violation 'bitwise-bit-field 2538 "2nd parameter must be less than or equal to 3rd parameter" 2539 (SG_LIST3 ei1 (SG_MAKE_INT ei2) (SG_MAKE_INT ei3)))) 2540 (let ((mask (Sg_LogNot (Sg_Ash (SG_MAKE_INT -1) ei3)))) 2541 (result (Sg_Ash (Sg_LogAnd ei1 mask) (- 0 ei2))))) 2542 2543 (define-c-proc bitwise-copy-bit-field 2544 (ei1::<number> ei2::<fixnum> ei3::<fixnum> ei4::<number>) :constant 2545 (let ((to ei1) 2546 (start::long ei2) 2547 (end::long ei3) 2548 (from ei4) 2549 (mask1 (Sg_Ash (SG_MAKE_INT -1) start)) 2550 (mask2 (Sg_LogNot (Sg_Ash (SG_MAKE_INT -1) end))) 2551 (mask (Sg_LogAnd mask1 mask2))) 2552 (result (logif mask (Sg_Ash from start) to)))) 2553 2554 (define-c-proc bitwise-arithmetic-shift (ei1::<number> ei2::<fixnum>) 2555 :constant Sg_Ash) 2556 2557 (define-c-proc bitwise-arithmetic-shift-left (ei1::<number> ei2::<fixnum>) 2558 :constant Sg_Ash) 2559 2560 (define-c-proc bitwise-arithmetic-shift-right (ei1::<number> ei2::<fixnum>) 2561 :constant 2562 (result (Sg_Ash ei1 (- 0 ei2)))) 2563 2564 ;; 12 syntax-case 2565 ;; 12.5 identifier predicates 2566 (define-c-proc identifier? (id) ::<boolean> :constant SG_IDENTIFIERP) 2567 2568 ;; free-identifier=? and bound-identifier=? are moved to Scheme 2569 2570 ;; 13 Hashtables 2571 ;; 13.1 constructors 2572 (define-cfn retrieve-weakness (weakness) ::SgWeakness :static 2573 (cond ((SG_EQ weakness 'key) (return SG_WEAK_KEY)) 2574 ((SG_EQ weakness 'value) (return SG_WEAK_VALUE)) 2575 ((SG_EQ weakness 'both) (return SG_WEAK_BOTH)) 2576 ;; NB: we don't support ephemerals 2577 (else (assertion-violation 'make-hashtable 2578 "weakness must be one of 'key, 'value or 'both" weakness) 2579 ;; dummy 2580 (return -1)))) 2581 2582 (define-c-proc make-eq-hashtable (:optional (k? #f) (weakness #f)) 2583 :no-side-effect 2584 (let ((k::long -1)) 2585 (cond ((SG_INTP k?) (set! k (SG_INT_VALUE k?))) 2586 ((SG_FALSEP k?) (set! k 200)) 2587 (else 2588 (wrong-type-of-argument-violation 'make-eq-hashtable 2589 "#f or fixnum" k?))) 2590 (when (< k 0) 2591 (wrong-type-of-argument-violation 'make-eq-hashtable 2592 "non negative exact integer" 2593 k?)) 2594 (if (SG_FALSEP weakness) 2595 (result (Sg_MakeHashTableSimple SG_HASH_EQ k)) 2596 (let ((w::SgWeakness (retrieve-weakness weakness))) 2597 (result (Sg_MakeWeakHashTableSimple SG_HASH_EQ w k SG_UNDEF)))))) 2598 2599 (define-c-proc make-eqv-hashtable (:optional (k? #f) (weakness #f)) 2600 :no-side-effect 2601 (let ((k::long -1)) 2602 (cond ((SG_INTP k?) (set! k (SG_INT_VALUE k?))) 2603 ((SG_FALSEP k?) (set! k 200)) 2604 (else 2605 (wrong-type-of-argument-violation 'make-eqv-hashtable 2606 "#f or fixnum" k?))) 2607 (when (< k 0) 2608 (wrong-type-of-argument-violation 'make-eqv-hashtable 2609 "non negative exact integer" 2610 (SG_MAKE_INT k))) 2611 (if (SG_FALSEP weakness) 2612 (result (Sg_MakeHashTableSimple SG_HASH_EQV k)) 2613 (let ((w::SgWeakness (retrieve-weakness weakness))) 2614 (result (Sg_MakeWeakHashTableSimple SG_HASH_EQV w k SG_UNDEF)))))) 2615 2616 (define-c-proc make-hashtable 2617 (hasher::<procedure> equiv::<procedure> :optional (k? #f) (weakness #f)) 2618 :no-side-effect 2619 (let ((k::long -1)) 2620 (cond ((SG_INTP k?) (set! k (SG_INT_VALUE k?))) 2621 ((SG_FALSEP k?) (set! k 200)) 2622 (else 2623 (wrong-type-of-argument-violation 'make-hashtable 2624 "#f or fixnum" k?))) 2625 (when (< k 0) 2626 (wrong-type-of-argument-violation 'make-hashtable 2627 "non negative exact integer" 2628 (SG_MAKE_INT k))) 2629 (if (SG_FALSEP weakness) 2630 (result (Sg_MakeHashTable hasher equiv k)) 2631 (let ((w::SgWeakness (retrieve-weakness weakness))) 2632 (result (Sg_MakeWeakHashTable hasher equiv w k SG_UNDEF)))))) 2633 2634 ;; 13.2 procedures 2635 (define-c-proc hashtable? (o) ::<boolean> :constant SG_HASHTABLE_P) 2636 2637 (define-c-proc hashtable-size (ht::<hashtable>) ::<fixnum> Sg_HashTableSize) 2638 2639 (define-c-proc hashtable-ref (ht::<hashtable> key :optional (fallback #f)) 2640 :no-side-effect (setter hashtable-set!) 2641 (result (Sg_HashTableRef ht key fallback))) 2642 2643 (define-cise-stmt check-mutable-hashtable 2644 ((_ name t) 2645 `(when (SG_IMMUTABLE_HASHTABLE_P ,t) 2646 (assertion-violation ',name 2647 "attemp to modify an immutable hashtable" ,t)))) 2648 2649 (define-c-proc hashtable-set! (ht::<hashtable> key value) ::<void> 2650 (check-mutable-hashtable hashtable-set! ht) 2651 (Sg_HashTableSet ht key value 0)) 2652 2653 (define-c-proc hashtable-delete! (ht::<hashtable> key) ::<void> 2654 (check-mutable-hashtable hashtable-set! ht) 2655 (Sg_HashTableDelete ht key)) 2656 2657 (define-c-proc hashtable-contains? (ht::<hashtable> key) ::<boolean> 2658 :no-side-effect 2659 (result (!= (Sg_HashTableRef ht key NULL) NULL))) 2660 2661 (define-c-proc hashtable-copy 2662 (ht::<hashtable> :optional (mutableP::<boolean> #f)) 2663 (result (Sg_HashTableCopy ht mutableP))) 2664 2665 (define-c-proc hashtable-clear! 2666 (ht::<hashtable> :optional (k::<fixnum> -1)) ::<void> 2667 (check-mutable-hashtable hashtable-clear! ht) 2668 (Sg_HashCoreClear (SG_HASHTABLE_CORE ht) k)) 2669 2670 (define-c-proc hashtable-keys (ht::<hashtable>) :no-side-effect 2671 (let ((itr::SgHashIter) 2672 (r (Sg_MakeVector (-> (SG_HASHTABLE_CORE ht) entryCount) SG_UNDEF)) 2673 (v) 2674 (i::int 0)) 2675 (Sg_HashIterInit ht (& itr)) 2676 (while (!= (Sg_HashIterNext (& itr) (& v) NULL) NULL) 2677 (set! (SG_VECTOR_ELEMENT r (post++ i)) v)) 2678 (result r))) 2679 2680 (define-c-proc hashtable-entries (ht::<hashtable>) :no-side-effect 2681 (let ((itr::SgHashIter) 2682 (rk (Sg_MakeVector (-> (SG_HASHTABLE_CORE ht) entryCount) SG_UNDEF)) 2683 (rv (Sg_MakeVector (-> (SG_HASHTABLE_CORE ht) entryCount) SG_UNDEF)) 2684 (v) 2685 (k) 2686 (i::int 0)) 2687 (Sg_HashIterInit ht (& itr)) 2688 (while (!= (Sg_HashIterNext (& itr) (& k) (& v)) NULL) 2689 (set! (SG_VECTOR_ELEMENT rk i) k) 2690 (set! (SG_VECTOR_ELEMENT rv (post++ i)) v)) 2691 (result (Sg_Values2 rk rv)))) 2692 2693 ;; 13.3 inspection 2694 (define-c-proc hashtable-mutable? (ht::<hashtable>) ::<boolean> :constant 2695 (result (not (SG_IMMUTABLE_HASHTABLE_P ht)))) 2696 2697 ;; 13.4 2698 ;; defined in compare.c 2699 ;; (define-c-proc equal-hash (o) ::<fixnum> :no-side-effect Sg_EqualHash) 2700 2701 ;; for srfi-13 we need to take bound as an argument 2702 (define-c-proc string-hash 2703 (o::<string> :optional bound (start::<fixnum> 0) (end::<fixnum> -1)) 2704 ::<fixnum> :no-side-effect 2705 (let ((modulo::long 0)) 2706 (cond ((SG_UNBOUNDP bound) (set! modulo (cast uint32_t SG_INT_MAX))) 2707 ((SG_INTP bound) (set! modulo (SG_INT_VALUE bound))) 2708 ((SG_BIGNUMP bound) 2709 (set! modulo (Sg_BignumToUI (SG_BIGNUM bound) SG_CLAMP_BOTH NULL)))) 2710 (when (== modulo 0) 2711 (assertion-violation 'string-hash 2712 "argument out of domain" 2713 bound)) 2714 (result (Sg_StringHash (Sg_MaybeSubstring o start end) modulo)))) 2715 2716 (define-c-proc string-ci-hash 2717 (o::<string> :optional bound (start::<fixnum> 0) (end::<fixnum> -1)) 2718 ::<fixnum> :no-side-effect 2719 (let ((modulo::long 0)) 2720 (cond ((SG_UNBOUNDP bound) (set! modulo (cast uint32_t SG_INT_MAX))) 2721 ((SG_INTP bound) (set! modulo (SG_INT_VALUE bound))) 2722 ((SG_BIGNUMP bound) 2723 (set! modulo (Sg_BignumToUI (SG_BIGNUM bound) SG_CLAMP_BOTH NULL)))) 2724 (when (== modulo 0) 2725 (assertion-violation 'string-hash 2726 "argument out of domain" 2727 bound)) 2728 (result (Sg_StringHash (Sg_StringFoldCase (Sg_MaybeSubstring o start end)) 2729 modulo)))) 2730 2731 (define-c-proc symbol-hash (o::<symbol> :optional ignore) :no-side-effect 2732 (result (Sg_MakeIntegerU (Sg_EqHash o 0)))) 2733 2734 ;; 15 composit library 2735 ;; 16 eval 2736 (define-c-proc eval (sexp env) Sg_VMEval) 2737 2738 (define-c-proc environment (:rest spec) 2739 (result (Sg_VMEnvironment (Sg_MakeEvalLibrary) spec))) 2740 2741 ;; 17 mutable pairs 2742 (define-c-proc set-car! (o::<pair> v) ::<void> (inline SET_CAR) 2743 (when (Sg_ConstantLiteralP o) 2744 (assertion-violation 'set-car "attempt to modify constant literal" o)) 2745 (SG_SET_CAR o v)) 2746 2747 (define-c-proc set-cdr! (o::<pair> v) ::<void> (inline SET_CDR) 2748 (when (Sg_ConstantLiteralP o) 2749 (assertion-violation 'set-cdr "attempt to modify constant literal" o)) 2750 (SG_SET_CDR o v)) 2751 2752 ;; 18 mutable strings 2753 (define-c-proc string-set! (s::<string> k::<fixnum> c::<char>) ::<void> 2754 Sg_StringSet) 2755 2756 ;; we take start and end as optional arguments for srfi-13 2757 (define-c-proc string-fill! (s::<string> c::<char> :optional 2758 (start::<fixnum> 0) 2759 (end::<fixnum> -1)) ::<void> 2760 (when (SG_IMMUTABLE_STRINGP s) 2761 (assertion-violation 'string-set! 2762 "attempted to modify an immutable string" 2763 s)) 2764 (Sg_StringFill s c start end)) 2765 2766 ;; record 2767 (define-c-proc %record? (o) ::<boolean> :constant Sg_RecordP) 2768 2769 ;; conditions 2770 (define-c-proc condition (:rest components) Sg_Condition) 2771 (define-c-proc simple-conditions (obj) Sg_SimpleConditions) 2772 2773 (define-c-proc compound-condition-component (obj) 2774 Sg_CompoundConditionComponent) 2775 2776 (define-c-proc compound-condition? (obj) ::<boolean> :constant 2777 Sg_CompoundConditionP) 2778 (define-c-proc simple-condition? (obj) ::<boolean> :constant 2779 Sg_SimpleConditionP) 2780 2781 (define-c-proc condition? (obj) ::<boolean> :constant Sg_ConditionP) 2782 2783 ) 2784