1 ;;;============================================================================
3 ;;; File: "_nonstd.scm"
5 ;;; Copyright (c) 1994-2012 by Marc Feeley, All Rights Reserved.
7 ;;;============================================================================
9 (##include "header.scm")
11 ;;;============================================================================
13 ;;; Implementation of exceptions.
15 (implement-library-type-error-exception)
17 (define-prim (##raise-error-exception message parameters)
19 (macro-make-error-exception
23 (implement-library-type-unbound-os-environment-variable-exception)
25 (define-prim (##raise-unbound-os-environment-variable-exception proc . args)
26 (##extract-procedure-and-arguments
32 (lambda (procedure arguments dummy1 dummy2 dummy3)
34 (macro-make-unbound-os-environment-variable-exception
38 ;;;----------------------------------------------------------------------------
40 ;;; Define type checking procedures.
42 (define-fail-check-type string-or-nonnegative-fixnum
43 'string-or-nonnegative-fixnum)
45 (define-fail-check-type will
48 (define-fail-check-type box
51 ;;;----------------------------------------------------------------------------
53 ;;; Non-standard procedures and special forms
55 ;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
57 (define-prim (##deconstruct-call src size proc)
58 (let* ((code (##source-strip src))
59 (n (##proper-length code)))
62 (##not (##fx= n size))
63 (##fx< n (##fx- 0 size))))
64 (##raise-expression-parsing-exception
65 'ill-formed-special-form
67 (##source-strip (##car code)))
68 (##apply proc (##cdr code)))))
70 (define-prim (##expand-source-template src template)
71 (let ((locat (##source-locat src)))
73 (define (expand template)
74 (cond ((##source? template)
78 (expand-list template)
82 (##list->vector (expand-list (##vector->list template)))
89 (define (expand-list template)
90 (cond ((or (##source? template)
94 (##cons (expand (##car template))
95 (expand-list (##cdr template))))
103 (define-prim (##source-strip x)
108 ;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
110 (define-prim (error message . parameters)
111 (##raise-error-exception message parameters))
113 ;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
115 (define-runtime-syntax parameterize
120 (lambda (bindings . body)
121 (##expand-source-template
123 (##parameterize-build
128 (define-prim (##parameterize-build src bindings body)
130 (define (build bindings rev-params-vals)
131 (cond ((##pair? bindings)
132 (let ((binding (##source-strip (##car bindings))))
133 (##shape src (##sourcify binding src) 2)
134 (let* ((param (##source-strip (##car binding)))
135 (val (##source-strip (##cadr binding))))
136 (build (##cdr bindings)
137 (##cons (##cons (##cons (##gensym) param)
138 (##cons (##gensym) val))
141 (if (##null? rev-params-vals)
142 (##cons 'let (##cons '() body))
143 (let ((params-vals (##reverse rev-params-vals)))
145 (define (bind params-vals)
146 (if (##null? params-vals)
147 (##cons 'let (##cons '() body))
148 (let* ((param-val (##car params-vals))
149 (param (##car param-val))
150 (val (##cdr param-val)))
151 (##list '##parameterize
156 (bind (##cdr params-vals)))))))
159 (let loop ((lst rev-params-vals) (bs '()))
162 (let* ((param-val (##car lst))
163 (param (##car param-val))
164 (val (##cdr param-val)))
166 (##cons (##list (##car param)
168 (##cons (##list (##car val)
171 (bind params-vals)))))
173 (##raise-expression-parsing-exception
174 'ill-formed-binding-list
177 (build (##source-strip bindings)
180 ;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
182 (define-runtime-syntax cond-expand
188 (##expand-source-template
194 (define-prim (##cond-expand-build src clauses)
196 (define (satisfied? feature-requirement)
197 (cond ((##symbol? feature-requirement)
198 (if (##member feature-requirement ##cond-expand-features)
201 ((##pair? feature-requirement)
202 (let ((first (##source-strip (##car feature-requirement))))
203 (cond ((##eq? first 'not)
204 (##shape src (##sourcify feature-requirement src) 2)
205 (##not (satisfied? (##source-strip (##cadr feature-requirement)))))
206 ((or (##eq? first 'and) (##eq? first 'or))
207 (##shape src (##sourcify feature-requirement src) -1)
208 (let loop ((lst (##cdr feature-requirement)))
210 (let ((x (##source-strip (##car lst))))
211 (if (##eq? (satisfied? x) (##eq? first 'and))
213 (##not (##eq? first 'and))))
214 (##eq? first 'and))))
217 (macro-make-expression-parsing-exception
218 'ill-formed-cond-expand
223 (macro-make-expression-parsing-exception
224 'ill-formed-cond-expand
228 (define (build clauses)
229 (if (##pair? clauses)
230 (let ((clause (##source-strip (##car clauses))))
231 (##shape src (##sourcify clause src) -1)
232 (let ((feature-requirement (##source-strip (##car clause))))
233 (if (or (and (##eq? feature-requirement 'else)
234 (##null? (##cdr clauses)))
235 (satisfied? feature-requirement))
236 (##cons 'begin (##cdr clause))
237 (build (##cdr clauses)))))
239 (macro-make-expression-parsing-exception
240 'unfulfilled-cond-expand
246 (##define-macro (generate-cond-expand-features)
248 (define gambits '(gambit GAMBIT Gambit gambit-c GAMBIT-C Gambit-C))
270 (define ##cond-expand-features #f)
271 (set! ##cond-expand-features (generate-cond-expand-features))
273 (define-runtime-macro (define-cond-expand-feature feature)
274 (set! ##cond-expand-features (##cons feature ##cond-expand-features))
277 ;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
279 (define-runtime-syntax receive
284 (lambda (formals expression . body)
285 (##expand-source-template
288 (lambda () ,expression)
289 (lambda ,formals ,@body)))))))
291 ;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
293 (define-prim (##type-field-count type)
295 (let ((fields (##type-fields type)))
296 (##fixnum.+ (##type-field-count (##type-super type))
297 (##fixnum.quotient (##vector-length fields) 3)))
300 (define-prim (##type-all-fields type)
302 (let ((fields (##type-fields type)))
303 (##append (##type-all-fields (##type-super type))
304 (##vector->list fields)))
307 (define-prim (##define-type-expand
310 super-type-dynamic-expr
327 (define (generate-fields)
328 (let loop ((lst1 (##reverse fields))
336 (##vector-ref descr 0))
338 (##vector-ref descr 4))
340 (##vector-ref descr 5))
342 (cond ((##assq 'init: attributes)
344 (lambda (x) (##constant-expression-value (##cdr x))))
352 (##list->vector lst2))))
354 (define (all-fields->rev-field-alist all-fields)
357 (rev-field-alist '()))
371 (loop (##fixnum.+ i 1)
373 (##cons (##cons field-name
377 (generate-parameter i)))
381 (define (generate-parameter i)
384 (##number->string i 10))))
386 (define (generate-parameters rev-field-alist)
387 (if (##pair? constructor)
388 (##map (lambda (field-name)
389 (let ((x (##assq field-name rev-field-alist)))
390 (##vector-ref (##cdr x) 3)))
392 (let loop ((lst rev-field-alist)
395 (let ((x (##car lst)))
398 (##vector-ref (##cdr x) 1))
400 (##not (##fixnum.= (##fixnum.bitwise-and options 8)
404 (##cons (##vector-ref (##cdr x) 3)
408 (define (generate-initializations field-alist parameters in-macro?)
410 (let* ((field-index (##vector-ref (##cdr x) 0))
411 (options (##vector-ref (##cdr x) 1))
412 (val (##vector-ref (##cdr x) 2))
413 (parameter (##vector-ref (##cdr x) 3)))
414 (if (##memq parameter parameters)
422 (define (make-quote x)
426 (##not (##fixnum.= (##fixnum.bitwise-and flags 4) 0)))
432 (##number->string total-fields 10)
434 (##symbol->string (if generative? name id))))
441 (##make-uninterned-symbol augmented-id-str)
442 (##string->symbol augmented-id-str))
449 (##string->symbol augmented-id-str)
454 (##declare (extended-bindings) (not safe))
455 (##type-id ,type-expression))
456 `',(##type-id type-static)))
458 (##type-all-fields type-static))
460 (all-fields->rev-field-alist all-fields))
462 (##reverse rev-field-alist))
464 (generate-parameters rev-field-alist)))
466 (define (generate-getter-and-setter field tail)
470 (##vector-ref descr 0))
472 (##vector-ref descr 1))
474 (##vector-ref descr 2))
476 (##vector-ref descr 3))
480 (if (##eq? getter #t)
481 (##symbol-append prefix
489 '##direct-structure-ref)))
491 `((##define-macro (,getter-name obj)
493 (##declare (extended-bindings))
499 `((define (,getter-name obj)
501 (##declare (extended-bindings))
511 (if (##eq? setter #t)
512 (##symbol-append prefix
521 '##direct-structure-set!)))
523 `((##define-macro (,setter-name obj val)
525 (##declare (extended-bindings))
532 `((define (,setter-name obj val)
534 (##declare (extended-bindings))
542 (##append getter-def (##append setter-def tail))))
544 (define (generate-structure-type-definition)
545 `(define ,type-expression
547 (##declare (extended-bindings))
551 (##declare (extended-bindings))
552 ##make-uninterned-symbol)
555 ',(##type-flags type-static)
556 ,super-type-dynamic-expr
557 ',(##type-fields type-static))))
559 (define (generate-constructor-predicate-getters-setters)
560 `(,@(if type-exhibitor
562 `((##define-macro (,type-exhibitor)
564 `((define (,type-exhibitor)
569 (let ((constructor-name
570 (if (##pair? constructor)
574 `((##define-macro (,constructor-name ,@parameters)
576 (##declare (extended-bindings))
579 ,@(generate-initializations
583 `((define (,constructor-name ,@parameters)
584 (##declare (extended-bindings))
587 ,@(generate-initializations
593 ,@(if constant-constructor
594 `((##define-macro (,constant-constructor ,@parameters)
595 (##define-type-construct-constant
596 ',constant-constructor
598 ,@(generate-initializations
606 `((##define-macro (,predicate obj)
608 ``(let ((obj ,,'obj))
609 (##declare (extended-bindings))
610 (and (##structure? obj)
611 (let ((t0 (##structure-type obj))
612 (type-id ,',type-id-expression))
613 (or (##eq? (##type-id t0) type-id)
614 (let ((t1 (##type-super t0)))
616 (or (##eq? (##type-id t1) type-id)
617 (##structure-instance-of? obj type-id))))))))
619 (##declare (extended-bindings))
620 ##structure-direct-instance-of?)
622 ,',type-id-expression))))
623 `((define (,predicate obj)
624 (##declare (extended-bindings))
626 `(##structure-instance-of?
629 `(##structure-direct-instance-of?
631 ,type-id-expression)))))
634 ,@(let loop ((lst1 (##reverse fields))
638 (generate-getter-and-setter (##car lst1) lst2))
641 (define (generate-definitions)
643 (##cons (generate-structure-type-definition)
644 (generate-constructor-predicate-getters-setters))
645 (generate-constructor-predicate-getters-setters)))
650 (##list `(##define-macro (,extender . args)
651 (##define-type-expand
660 (##cons `(##define-macro (,implementer)
662 (generate-structure-type-definition)
664 (generate-constructor-predicate-getters-setters))
665 (##list `(##define-macro (,implementer)
667 (generate-definitions)))))
668 (generate-definitions)))))
671 (##define-type-parser
676 (if ##define-type-expansion-show?
677 (pp expansion ##stdout-port))
680 (define ##define-type-expansion-show? #f)
681 (set! ##define-type-expansion-show? #f)
683 (define-prim (##define-type-parser
690 (##ill-formed-special-form form-name args))
692 (define (parse-attributes name rest)
693 (let loop1 ((lst rest)
694 (field-index (##type-field-count super-type-static))
699 (define allowed-field-options
700 '((printable: . (-2 . 0))
701 (unprintable: . (-2 . 1))
702 (read-write: . (-3 . 0))
703 (read-only: . (-3 . 2))
704 (equality-test: . (-5 . 0))
705 (equality-skip: . (-5 . 4))))
707 (define (update-options options opt)
708 (let* ((x (##cdr opt))
711 (##fixnum.bitwise-ior (##fixnum.bitwise-and options m) b)))
713 (define (parse-field-attributes
719 (let loop2 ((lst2 rest)
720 (local-options local-options)
722 (cond ((##pair? lst2)
723 (let ((attribute (##car lst2)))
724 (cond ((##assq attribute
725 '((init: . (-9 . 8))))
728 (let ((rest (##cdr lst2)))
729 (if (and (##pair? rest)
730 (##not (##assq attribute attributes)))
731 (let ((val (##car rest)))
732 (if (##constant-expression? val)
734 (update-options local-options opt)
735 (##cons (##cons attribute val)
740 allowed-field-options)
744 (update-options local-options opt)
751 (##fixnum.= (##fixnum.bitwise-and local-options 2)
753 (if (and (##symbol? setter)
757 (##fixnum.+ field-index 1)
760 (##cons (##cons field-name
763 (##fixnum.+ field-index 1)
765 (if read-only? #f setter)
773 (let ((next (##car lst)))
774 (cond ((##symbol? next)
775 (if (##not (##assq next rev-fields))
776 (parse-field-attributes
784 (let* ((field-name (##car next))
786 (if (and (##symbol? field-name)
787 (##not (##assq field-name rev-fields)))
789 (let ((getter (##car rest)))
790 (if (##symbol? getter)
791 (let ((rest (##cdr rest)))
793 (let ((setter (##car rest)))
794 (if (##symbol? setter)
795 (parse-field-attributes
799 (##fixnum.bitwise-and options -3)
801 (parse-field-attributes
805 (##fixnum.bitwise-ior options 2)
807 (parse-field-attributes
811 (##fixnum.bitwise-ior options 2)
813 (parse-field-attributes
819 (parse-field-attributes
829 constant-constructor:
835 (let ((rest (##cdr lst)))
836 (if (and (##pair? rest)
837 (##not (##assq next flags)))
838 (let ((val (##car rest)))
839 (if (cond ((##eq? next 'constructor:)
841 (if (##symbol? (##car val))
842 (let loop ((lst1 (##cdr val))
845 (let ((x (##car lst1)))
846 (if (and (##symbol? x)
862 constant-constructor:))
867 (##cons (##cons next val) flags)
874 (if (##not (##assq next flags))
878 (##cons (##cons next #t) flags)
882 allowed-field-options)
887 (update-options options opt)
894 (##reverse rev-fields))
896 (cond ((##assq 'prefix: flags)
902 (cond ((##assq 'id: flags)
908 (cond ((##assq 'extender: flags)
914 (cond ((##assq 'constructor: flags)
917 (let ((constructor (##cdr x)))
918 (if (##pair? constructor)
919 (##for-each (lambda (sym)
920 (if (##not (##assq sym fields))
922 (##cdr constructor)))
925 (##symbol-append prefix
928 (constant-constructor
929 (cond ((##assq 'constant-constructor: flags)
932 ((or (##not constructor)
936 (##symbol-append prefix
940 (cond ((##assq 'predicate: flags)
944 (##symbol-append prefix
948 (cond ((##assq 'implementer: flags)
954 (cond ((##assq 'type-exhibitor: flags)
959 (if (or (and constant-constructor
960 (or (##not constructor)
965 (##fixnum.bitwise-and
966 (##type-flags super-type-static)
972 (##fixnum.+ (if (or (##assq 'opaque: flags)
973 (and super-type-static
976 (##fixnum.bitwise-and
977 (##type-flags super-type-static)
983 (if (##assq 'macros: flags) 4 0)
1000 (let* ((name (##car args))
1001 (rest (##cdr args)))
1002 (if (##symbol? name)
1003 (parse-attributes name rest)
1007 (define-prim (##define-type-construct-constant form-name type . fields)
1008 (let loop ((lst1 fields)
1011 (let ((field (##car lst1)))
1012 (if (##constant-expression? field)
1014 (##cons (##constant-expression-value field)
1016 (##ill-formed-special-form form-name fields)))
1017 `',(##apply ##structure
1018 (##cons type (##reverse lst2))))))
1020 (define-prim (##ill-formed-special-form form-name args)
1021 (##raise-expression-parsing-exception
1022 'ill-formed-special-form
1024 (##cons form-name args)
1025 (##make-source #f #f))
1028 (define-prim (##constant-expression? expr)
1029 (or (##self-eval? expr)
1031 (##eq? (##car expr) 'quote)
1032 (let ((rest (##cdr expr)))
1034 (##null? (##cdr rest)))))))
1036 (define-prim (##constant-expression-value expr)
1037 (if (##self-eval? expr)
1041 (define-prim (##symbol-append . symbols)
1043 (##apply ##string-append
1044 (##map ##symbol->string symbols))))
1046 (define-runtime-macro (define-type . args)
1047 (##define-type-expand 'define-type #f #f args))
1049 (define-runtime-macro (define-structure . args)
1050 (##define-type-expand 'define-structure #f #f args))
1052 (define-runtime-macro (define-record-type name constructor predicate . fields)
1054 constructor: ,constructor
1055 predicate: ,predicate
1058 ;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1060 (define-runtime-macro (define-type-of-thread . args)
1061 (##define-type-expand
1062 'define-type-of-thread
1064 (##list 'quote (macro-type-thread))
1067 ;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1069 (define-prim (gc-report-set! report?);;;;;;;;;;;;;;;;;;;;;;
1070 (##gc-report-set! report?))
1072 (define ##gc-report? #f)
1074 (define-prim (##gc-report-set! report?)
1075 (##declare (not interrupts-enabled))
1076 (set! ##gc-report? (if report? #t #f)))
1078 (define-prim (##display-gc-report)
1080 ;;;;;;;;;;; report is not accurate on 64 bit machines
1082 (if (let* ((settings
1083 (##set-debug-settings! 0 0))
1085 (macro-debug-settings-level settings)))
1086 (or (##fixnum.< 1 level)
1089 (##process-statistics))
1091 (##f64vector-ref stats 14))
1093 (##f64vector-ref stats 15))
1095 (##f64vector-ref stats 16))
1097 (##f64vector-ref stats 17))
1099 (##f64vector-ref stats 18))
1101 (##f64vector-ref stats 19))
1103 (##repl-output-port)))
1106 (##flonum.->exact-int (##flonum.round (##flonum.* x m))))
1108 (define (mem bytes suffix)
1110 (define (show x*1000 unit)
1112 (define (decimals d)
1113 (let* ((n (##round (##/ x*1000 (##expt 10 (##fixnum.- 3 d)))))
1114 (n-str (##number->string n 10))
1115 (n-str-len (##string-length n-str))
1116 (str (if (##fixnum.< n-str-len d)
1118 (##make-string (##fixnum.- d n-str-len) #\0)
1121 (len (##string-length str))
1122 (split (##fixnum.- len d)))
1124 (if (##fixnum.= d 0)
1126 (##string-append (##substring str 0 split)
1128 (##substring str split len)))
1130 (##write-string unit output-port)))
1132 (cond ((##< x*1000 10000)
1134 ((##< x*1000 100000)
1139 (let ((k (scale bytes 9.765625e-1)))
1142 (let ((m (scale bytes 9.5367431640625e-4)))
1145 (let ((g (scale bytes 9.313225746154785e-7)))
1147 (##write-string suffix output-port))
1149 (##write-string "*** GC: " output-port)
1150 (##write (scale last-gc-real-time 1000.0) output-port)
1151 (##write-string " ms, " output-port)
1152 (mem last-gc-alloc " alloc, ")
1153 (mem last-gc-heap-size " heap, ")
1154 (mem last-gc-live " live (")
1155 (##write (scale (##flonum./ last-gc-live last-gc-heap-size) 100.0) output-port)
1156 (##write-string "% " output-port)
1157 (##write (##flonum.->exact-int last-gc-movable) output-port)
1158 (##write-string "+" output-port)
1159 (##write (##flonum.->exact-int last-gc-nonmovable) output-port)
1160 (##write-string ")" output-port)
1161 (##newline output-port)
1164 (##add-gc-interrupt-job! ##display-gc-report)
1166 ;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1168 (define-prim (##void))
1173 ;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1175 (define-prim (process-times)
1178 (define-prim (cpu-time)
1179 (let ((v (##process-times)))
1180 (##+ (##f64vector-ref v 0) (##f64vector-ref v 1))))
1182 (define-prim (real-time)
1183 (let ((v (##process-times)))
1184 (##f64vector-ref v 2)))
1186 ;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1188 (define ##gensym-counter -1)
1190 (define-prim (##gensym #!optional (p (macro-absent-obj)))
1192 (if (##eq? p (macro-absent-obj))
1195 (macro-check-symbol prefix 1 (gensym p)
1198 (##fixnum.+ ##gensym-counter 1)
1200 ;; Note: it is unimportant if the increment of ##gensym-counter
1201 ;; is not atomic; it simply means a possible close repetition
1203 (set! ##gensym-counter new-count)
1204 (##make-uninterned-symbol
1205 (if (##eq? prefix 'g)
1206 new-count ;; ##symbol->string will create the string
1207 (##string-append (##symbol->string prefix)
1208 (##number->string new-count 10))))))))
1210 (define-prim (gensym #!optional (p (macro-absent-obj)))
1211 (macro-force-vars (p)
1214 ;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1216 (##define-macro (macro-will-size) 3)
1218 (define-prim (##will? obj)
1219 (and (##subtyped? obj)
1220 (##eq? (##subtype obj) (macro-subtype-weak))
1221 (##fixnum.= (##vector-length obj) (macro-will-size))))
1223 (define-prim (will? x)
1224 (macro-force-vars (x)
1227 (define-prim (##make-will testator action)
1228 (macro-make-will testator action))
1230 (define-prim (make-will testator action)
1231 (macro-force-vars (action)
1232 (macro-check-procedure action 2 (make-will testator action)
1233 (macro-make-will testator action))))
1235 (define-prim (##will-testator will)
1236 (macro-will-testator will))
1238 (define-prim (will-testator will)
1239 (macro-force-vars (will)
1240 (macro-check-will will 1 (will-testator will)
1241 (macro-will-testator will))))
1243 (define-prim (##will-execute! will)
1244 (macro-will-execute! will))
1246 (define-prim (will-execute! will)
1247 (macro-force-vars (will)
1248 (macro-check-will will 1 (will-execute! will)
1249 (macro-will-execute! will))))
1251 ;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1253 (define-prim (##box? obj)
1254 (and (##subtyped? obj)
1255 (##eq? (##subtype obj) (macro-subtype-boxvalues))
1256 (##fixnum.= (##vector-length obj) 1)))
1258 (define-prim (box? obj)
1259 (macro-force-vars (obj)
1262 (define-prim (##box obj)
1263 (##subtype-set! (##vector obj) (macro-subtype-boxvalues)))
1265 (define-prim (box obj)
1268 (define-prim (##unbox box)
1269 (##vector-ref box 0))
1271 (define-prim (unbox box)
1272 (macro-force-vars (box)
1273 (macro-check-box box 1 (unbox box)
1276 (define-prim (##set-box! box val)
1277 (##vector-set! box 0 val))
1279 (define-prim (set-box! box val)
1280 (macro-force-vars (box)
1281 (macro-check-box box 1 (set-box! box val)
1283 (##set-box! box val)
1286 ;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1288 (define-prim (exit #!optional (status (macro-absent-obj)))
1289 (if (##eq? status (macro-absent-obj))
1291 (macro-force-vars (status)
1292 (macro-check-exact-unsigned-int8 status 1 (exit status)
1295 (define-prim (##getenv name #!optional (default-value (macro-absent-obj)))
1296 (let ((result (##os-getenv name)))
1297 (cond ((##fixnum? result)
1298 (##raise-os-exception #f result getenv name default-value))
1300 (if (##eq? default-value (macro-absent-obj))
1301 (##raise-unbound-os-environment-variable-exception
1308 (define-prim (getenv name #!optional (default-value (macro-absent-obj)))
1309 (macro-force-vars (name)
1310 (macro-check-string name 1 (getenv name default-value)
1311 (##getenv name default-value))))
1313 (define-prim (##setenv name #!optional (value (macro-absent-obj)))
1314 (let ((code (##os-setenv name value)))
1315 (if (##fixnum.< code 0)
1316 (##raise-os-exception #f code setenv name value)
1319 (define-prim (setenv name #!optional (value (macro-absent-obj)))
1320 (macro-force-vars (name value)
1321 (macro-check-string name 1 (setenv name value)
1322 (if (##eq? value (macro-absent-obj))
1324 (macro-check-string value 2 (setenv name value)
1325 (##setenv name value))))))
1327 (define-prim (command-line)
1328 ##processed-command-line)
1330 (define-prim (##shell-command-blocking cmd)
1332 (let ((code (##os-shell-command cmd (##current-directory))))
1333 (if (##fixnum.< code 0)
1334 (##raise-os-exception #f code ##shell-command-blocking cmd)
1337 (define ##shell-program #f)
1339 (define-prim (##get-shell-program)
1341 (define unix-shell-program '("/bin/sh" . "-c"))
1342 (define windows-shell-program '("CMD.EXE" . "/C"))
1343 (define default-shell-program '("sh" . "-c"))
1347 (if (##file-exists? (##car unix-shell-program))
1349 (if (##getenv "HOME" #f)
1350 default-shell-program
1351 (let ((comspec (##getenv "COMSPEC" #f)))
1353 (##cons comspec "/C")
1354 windows-shell-program))))))
1355 (set! ##shell-program sp)
1358 (define-prim (##shell-command cmd)
1360 (##get-shell-program))
1362 (##list path: (##car shell-prog)
1367 stdin-redirection: #f
1368 stdout-redirection: #f
1369 stderr-redirection: #f)))
1370 (##open-process-generic
1371 (macro-direction-inout)
1375 (##process-status port))
1380 (define-prim (##escape-string str escape-char to-escape)
1382 (##string-length str))
1384 (let loop1 ((i (##fixnum.- len 1))
1386 (if (##fixnum.< i 0)
1388 (let ((c (##string-ref str i)))
1389 (loop1 (##fixnum.- i 1)
1390 (if (##memq c to-escape)
1394 (##fixnum.+ len nb-escapes))
1396 (##make-string escaped-len 0)))
1397 (let loop2 ((i (##fixnum.- len 1))
1398 (j (##fixnum.- escaped-len 1)))
1399 (if (and (##not (##fixnum.< i 0)) (##not (##fixnum.< j 0)))
1400 (let ((c (##string-ref str i)))
1401 (##string-set! escaped-str j c)
1402 (loop2 (##fixnum.- i 1)
1403 (if (and (##fixnum.< 0 j)
1404 (##memq c to-escape))
1406 (##string-set! escaped-str
1413 (define-prim (shell-command cmd)
1414 (macro-force-vars (cmd)
1415 (macro-check-string cmd 1 (shell-command cmd)
1416 (##shell-command cmd))))
1418 ;;;----------------------------------------------------------------------------
1420 ;;; Implementation of file-info objects.
1422 (implement-library-type-file-info)
1424 (define-prim (##file-info
1427 (chase? (macro-absent-obj)))
1428 (let* ((resolved-path
1429 (##path-resolve path))
1431 (##os-file-info resolved-path
1432 (if (##eq? chase? (macro-absent-obj))
1435 (if (##fixnum? result)
1439 (case (##vector-ref result 1)
1442 ((3) 'character-special)
1443 ((4) 'block-special)
1445 ((6) 'symbolic-link)
1448 (##vector-set! result 1 type))
1449 (##vector-set! result 9
1450 (macro-make-time (##vector-ref result 9) #f #f #f))
1451 (##vector-set! result 10
1452 (macro-make-time (##vector-ref result 10) #f #f #f))
1453 (##vector-set! result 11
1454 (macro-make-time (##vector-ref result 11) #f #f #f))
1455 (##vector-set! result 13
1456 (macro-make-time (##vector-ref result 13) #f #f #f))
1457 (##structure-type-set! result (macro-type-file-info))
1458 (##subtype-set! result (macro-subtype-structure))
1461 (define-prim (file-info
1464 (chase? (macro-absent-obj)))
1465 (macro-force-vars (path chase?)
1466 (macro-check-string path 1 (file-info path chase?)
1467 (let ((info (##file-info path chase?)))
1468 (if (##fixnum? info)
1469 (##raise-os-exception #f info file-info path chase?)
1472 (define-prim (file-type path)
1473 (macro-force-vars (path)
1474 (macro-check-string path 1 (file-type path)
1475 (let ((info (##file-info path)))
1476 (if (##fixnum? info)
1477 (##raise-os-exception #f info file-type path)
1478 (macro-file-info-type info))))))
1480 (define-prim (file-device path)
1481 (macro-force-vars (path)
1482 (macro-check-string path 1 (file-device path)
1483 (let ((info (##file-info path)))
1484 (if (##fixnum? info)
1485 (##raise-os-exception #f info file-device path)
1486 (macro-file-info-device info))))))
1488 (define-prim (file-inode path)
1489 (macro-force-vars (path)
1490 (macro-check-string path 1 (file-inode path)
1491 (let ((info (##file-info path)))
1492 (if (##fixnum? info)
1493 (##raise-os-exception #f info file-inode path)
1494 (macro-file-info-inode info))))))
1496 (define-prim (file-mode path)
1497 (macro-force-vars (path)
1498 (macro-check-string path 1 (file-mode path)
1499 (let ((info (##file-info path)))
1500 (if (##fixnum? info)
1501 (##raise-os-exception #f info file-mode path)
1502 (macro-file-info-mode info))))))
1504 (define-prim (file-number-of-links path)
1505 (macro-force-vars (path)
1506 (macro-check-string path 1 (file-number-of-links path)
1507 (let ((info (##file-info path)))
1508 (if (##fixnum? info)
1509 (##raise-os-exception #f info file-number-of-links path)
1510 (macro-file-info-number-of-links info))))))
1512 (define-prim (file-owner path)
1513 (macro-force-vars (path)
1514 (macro-check-string path 1 (file-owner path)
1515 (let ((info (##file-info path)))
1516 (if (##fixnum? info)
1517 (##raise-os-exception #f info file-owner path)
1518 (macro-file-info-owner info))))))
1520 (define-prim (file-group path)
1521 (macro-force-vars (path)
1522 (macro-check-string path 1 (file-group path)
1523 (let ((info (##file-info path)))
1524 (if (##fixnum? info)
1525 (##raise-os-exception #f info file-group path)
1526 (macro-file-info-group info))))))
1528 (define-prim (file-size path)
1529 (macro-force-vars (path)
1530 (macro-check-string path 1 (file-size path)
1531 (let ((info (##file-info path)))
1532 (if (##fixnum? info)
1533 (##raise-os-exception #f info file-size path)
1534 (macro-file-info-size info))))))
1536 (define-prim (file-last-access-time path)
1537 (macro-force-vars (path)
1538 (macro-check-string path 1 (file-last-access-time path)
1539 (let ((info (##file-info path)))
1540 (if (##fixnum? info)
1541 (##raise-os-exception #f info file-last-access-time path)
1542 (macro-file-info-last-access-time info))))))
1544 (define-prim (file-last-modification-time path)
1545 (macro-force-vars (path)
1546 (macro-check-string path 1 (file-last-modification-time path)
1547 (let ((info (##file-info path)))
1548 (if (##fixnum? info)
1549 (##raise-os-exception #f info file-last-modification-time path)
1550 (macro-file-info-last-modification-time info))))))
1552 (define-prim (file-last-change-time path)
1553 (macro-force-vars (path)
1554 (macro-check-string path 1 (file-last-change-time path)
1555 (let ((info (##file-info path)))
1556 (if (##fixnum? info)
1557 (##raise-os-exception #f info file-last-change-time path)
1558 (macro-file-info-last-change-time info))))))
1560 (define-prim (file-attributes path)
1561 (macro-force-vars (path)
1562 (macro-check-string path 1 (file-attributes path)
1563 (let ((info (##file-info path)))
1564 (if (##fixnum? info)
1565 (##raise-os-exception #f info file-attributes path)
1566 (macro-file-info-attributes info))))))
1568 (define-prim (file-creation-time path)
1569 (macro-force-vars (path)
1570 (macro-check-string path 1 (file-creation-time path)
1571 (let ((info (##file-info path)))
1572 (if (##fixnum? info)
1573 (##raise-os-exception #f info file-creation-time path)
1574 (macro-file-info-creation-time info))))))
1576 ;;;----------------------------------------------------------------------------
1578 (define-prim (##file-exists?
1581 (chase? (macro-absent-obj)))
1582 (let* ((resolved-path
1583 (##path-resolve path))
1585 (##os-file-info resolved-path
1586 (if (##eq? chase? (macro-absent-obj))
1589 (##not (##fixnum? result))))
1591 (define-prim (file-exists?
1594 (chase? (macro-absent-obj)))
1595 (macro-force-vars (path chase?)
1596 (macro-check-string path 1 (file-exists? path chase?)
1597 (##file-exists? path chase?))))
1599 ;;;----------------------------------------------------------------------------
1601 ;;; Implementation of user-info objects.
1603 (implement-library-type-user-info)
1605 (define-prim (##user-info user)
1606 (let ((result (##os-user-info user)))
1607 (if (##fixnum? result)
1608 (##raise-os-exception #f result user-info user)
1610 (##structure-type-set! result (macro-type-user-info))
1611 (##subtype-set! result (macro-subtype-structure))
1614 (define-prim (user-info user)
1615 (macro-force-vars (user)
1616 (macro-check-string-or-nonnegative-fixnum user 1 (user-info user)
1617 (##user-info user))))
1619 (define-prim (##user-name)
1620 (let ((result (##os-user-name)))
1621 (if (##fixnum? result)
1622 (##raise-os-exception #f result user-name)
1625 (define-prim (user-name)
1628 ;;;----------------------------------------------------------------------------
1630 ;;; Implementation of group-info objects.
1632 (implement-library-type-group-info)
1634 (define-prim (##group-info group)
1635 (let ((result (##os-group-info group)))
1636 (if (##fixnum? result)
1637 (##raise-os-exception #f result group-info group)
1639 (##structure-type-set! result (macro-type-group-info))
1640 (##subtype-set! result (macro-subtype-structure))
1643 (define-prim (group-info group)
1644 (macro-force-vars (group)
1645 (macro-check-string-or-nonnegative-fixnum group 1 (group-info group)
1646 (##group-info group))))
1648 ;;;----------------------------------------------------------------------------
1650 ;;; Pathname operations.
1652 (define-prim (##path-volume-end-using-dir-sep path directory-separator)
1653 (cond ((##char=? #\: directory-separator)
1655 (if (##fixnum.< i (##string-length path))
1656 (let ((c (##string-ref path i)))
1657 (if (##char=? #\: c)
1659 (loop1 (##fixnum.+ i 1))))
1661 ((##char=? #\\ directory-separator)
1662 (if (##fixnum.= 0 (##string-length path))
1664 (let ((c (##string-ref path 0)))
1665 (cond ((or (and (##char<=? #\a c)
1667 (and (##char<=? #\A c)
1669 (if (and (##fixnum.< 1 (##string-length path))
1670 (##char=? #\: (##string-ref path 1)))
1673 ((or (##char=? #\\ c)
1675 (if (and (##fixnum.< 1 (##string-length path))
1676 (let ((c (##string-ref path 1)))
1677 (or (##char=? #\\ c)
1682 (if (##fixnum.< i (##string-length path))
1683 (let ((c (##string-ref path i)))
1684 (cond ((##not (or (##char=? #\\ c)
1686 (loop2 (##fixnum.+ i 1)
1689 ((##fixnum.= i (##fixnum.+ last 1))
1691 ((##fixnum.= nb-seps 3)
1694 (loop2 (##fixnum.+ i 1)
1695 (##fixnum.+ nb-seps 1)
1697 (if (or (##fixnum.< nb-seps 3)
1698 (##fixnum.= i (##fixnum.+ last 1)))
1707 (define ##path-resolve-hook #f)
1708 (set! ##path-resolve-hook #f)
1710 (define-prim (##path-resolve path)
1711 (let ((pr-hook ##path-resolve-hook))
1712 (if (##procedure? pr-hook)
1715 (if (##string? result)
1717 (##raise-error-exception
1718 "STRING result expected but got"
1720 (##default-path-resolve path))))
1722 (define-prim (##default-path-resolve path)
1723 (##path-expand path))
1725 (define ##path-expand-hook #f)
1726 (set! ##path-expand-hook #f)
1728 (define-prim (##path-expand
1731 (origin (macro-absent-obj)))
1732 (let ((pe-hook ##path-expand-hook))
1733 (if (##procedure? pe-hook)
1735 (if (##eq? origin (macro-absent-obj))
1737 (pe-hook path origin))))
1738 (if (##string? result)
1740 (##raise-error-exception
1741 "STRING result expected but got"
1743 (if (##eq? origin (macro-absent-obj))
1744 (##default-path-expand path)
1745 (##default-path-expand path origin)))))
1747 (define-prim (##default-path-expand
1750 (origin (macro-absent-obj)))
1752 (##current-directory))
1753 (directory-separator
1754 (if (##fixnum.< 0 (##string-length cd))
1755 (##string-ref cd (##fixnum.- (##string-length cd) 1))
1758 (define (expand p orig)
1760 (define (relative dir-sep?)
1764 (let* ((d orig) ;; (expand orig #f)
1765 (len (##string-length d)))
1766 (if (or (##fixnum.= len 0)
1767 (##char=? (##string-ref d
1769 directory-separator))
1773 (##string directory-separator))))))
1776 (if (##char=? #\: directory-separator)
1777 (##fixnum.- (##string-length dir) 1)
1778 (##path-volume-end-using-dir-sep
1780 directory-separator))
1781 (##string-length dir))))
1782 (if (##fixnum.= len 0)
1786 (##fixnum.+ len (##string-length p)))))
1787 (##substring-move! dir 0 len result 0)
1788 (##substring-move! p 0 (##string-length p) result len)
1791 (define (absolute vol-end dir-sep?)
1795 (##make-string (##fixnum.+ 1 (##string-length p)))))
1796 (##substring-move! p 0 vol-end result 0)
1797 (##string-set! result vol-end directory-separator)
1798 (##substring-move! p vol-end (##string-length p) result (##fixnum.+ vol-end 1))
1802 (if (##fixnum.= 0 (##string-length p))
1804 (if (##char=? #\~ (##string-ref p 0))
1806 (if (##fixnum.< i (##string-length p))
1807 (let ((c (##string-ref p i)))
1808 (cond ((or (##char=? c directory-separator)
1809 (and (##char=? #\\ directory-separator)
1813 (loop (##fixnum.+ i 1)))))
1817 (define (prepend-directory dir start)
1819 (##raise-os-exception #f dir path-expand path origin)
1821 (##string-length dir))
1823 (and (##fixnum.< 0 dir-len)
1824 (##char=? directory-separator
1825 (##string-ref dir (##fixnum.- dir-len 1)))))
1827 (if ends-with-dir-sep? (##fixnum.- dir-len 1) dir-len))
1829 (##fixnum.- (##string-length p)
1833 1 ;; for directory separator
1834 (if (##fixnum.< 0 rest-len)
1835 (##fixnum.- rest-len 1)
1838 (##make-string len)))
1839 (##substring-move! dir 0 dir-end result 0)
1840 (##substring-move! p start (##string-length p) result dir-end)
1841 (##string-set! result dir-end directory-separator)
1842 (expand result orig))))
1845 (##raise-os-exception #f code path-expand path origin))
1847 (define (expand-in-instdir relpath instdir-name)
1848 (let ((dir (##os-path-gambcdir-map-lookup instdir-name)))
1849 (cond ((##fixnum? dir)
1852 (expand relpath dir))
1854 (let ((dir (##os-path-gambcdir)))
1855 (cond ((##fixnum? dir)
1857 ((##fixnum.= 0 (##string-length instdir-name))
1858 (expand relpath dir))
1861 (expand instdir-name dir)))))))))
1863 (let ((t-end (tilde-end)))
1864 (if (##fixnum.< 0 t-end)
1866 (cond ((##fixnum.= 1 t-end)
1867 (let ((homedir (##os-path-homedir)))
1868 (cond ((##fixnum? homedir)
1871 (prepend-directory homedir t-end))
1873 (expand "~~" #f)))))
1874 ((##char=? #\~ (##string-ref p 1))
1876 (##string-length p))
1878 (##substring p 2 t-end))
1881 (if (##fixnum.= t-end len)
1883 (##fixnum.+ t-end 1))
1889 (let ((info (##os-user-info (##substring p 1 t-end))))
1891 (if (##fixnum? info)
1893 (##vector-ref info 4)) ;; home dir
1897 (##path-volume-end-using-dir-sep p directory-separator))
1899 (and (##fixnum.< vol-end (##string-length p))
1900 (let ((c (##string-ref p vol-end)))
1901 (or (##char=? c directory-separator)
1902 (and (##char=? #\\ directory-separator)
1903 (##char=? #\/ c)))))))
1904 (if (##fixnum.= vol-end 0)
1906 (absolute vol-end dir-sep?))))))
1908 (expand path (if (##eq? origin (macro-absent-obj)) #f origin))))
1910 (define-prim (path-expand
1913 (origin (macro-absent-obj)))
1914 (macro-force-vars (path origin)
1915 (macro-check-string path 1 (path-expand path origin)
1916 (if (##eq? origin (macro-absent-obj))
1917 (##path-expand path)
1918 (macro-check-string origin 2 (path-expand path origin)
1919 (##path-expand path origin))))))
1921 (define-prim (##path-normalize
1924 (allow-relative? (macro-absent-obj))
1925 (origin (macro-absent-obj))
1926 (raise-os-exception? (macro-absent-obj)))
1928 (define (normalize path)
1930 (##os-path-normalize-directory path)))
1933 (##os-path-normalize-directory (##path-directory path))))
1934 (if (##fixnum? parent-dir)
1936 (##string-append parent-dir (##path-strip-directory path))))
1940 (##current-directory))
1941 (directory-separator
1942 (##string-ref cd (##fixnum.- (##string-length cd) 1)))
1944 (if (or (##not origin) (##eq? origin (macro-absent-obj)))
1946 (normalize (##path-expand origin cd))))
1948 (normalize (##path-expand path dir))))
1950 (if raise-os-exception?
1951 (##raise-os-exception
1958 raise-os-exception?)
1960 (if (or (##eq? allow-relative? (macro-absent-obj))
1961 (##not allow-relative?))
1965 (if (and (##fixnum.< i (##string-length dir))
1966 (##fixnum.< i (##string-length p))
1967 (##char=? (##string-ref dir i) (##string-ref p i)))
1968 (loop1 (##fixnum.+ i 1))
1971 (##path-volume-end-using-dir-sep dir directory-separator)))
1972 (if (##fixnum.< first-diff vol-end)
1974 (let* ((common-dir-end
1975 (let loop2 ((i (##fixnum.- first-diff 1)))
1976 (if (##fixnum.< i vol-end)
1978 (let ((c (##string-ref dir i)))
1979 (if (or (##char=? c directory-separator)
1980 (and (##char=? #\\ directory-separator)
1983 (loop2 (##fixnum.- i 1)))))))
1985 (let loop3 ((i first-diff) (nb-hops 0))
1986 (if (##fixnum.< i (##string-length dir))
1987 (loop3 (##fixnum.+ i 1)
1988 (let ((c (##string-ref dir i)))
1989 (if (or (##char=? c directory-separator)
1990 (and (##char=? #\\ directory-separator)
1992 (##fixnum.+ nb-hops 1)
1994 (if (and (##char=? #\: directory-separator)
1995 (or (##fixnum.< 0 nb-hops)
1996 (let loop4 ((i first-diff))
1997 (if (##fixnum.< i (##string-length p))
2001 (loop4 (##fixnum.+ i 1)))
2003 (##fixnum.+ nb-hops 1)
2006 (cond ((##char=? #\: directory-separator)
2008 ((##char=? #\\ directory-separator)
2013 (##fixnum.* (##string-length hop) nb-hops))
2015 (##fixnum.- common-dir-end hop-len)))
2017 (if (and (##fixnum.< length-reduction (##string-length p))
2018 (or (##not (##eq? allow-relative? 'shortest))
2019 (##fixnum.< 0 length-reduction)))
2022 (##fixnum.- (##string-length p) length-reduction))))
2029 (let loop5 ((i (##fixnum.- nb-hops 1)))
2030 (if (##fixnum.< i 0)
2036 (##string-length hop)
2038 (##fixnum.* i (##string-length hop)))
2039 (loop5 (##fixnum.- i 1))))))
2042 (define-prim (path-normalize
2045 (allow-relative? (macro-absent-obj))
2046 (origin (macro-absent-obj))
2047 (raise-os-exception? (macro-absent-obj)))
2048 (macro-force-vars (path allow-relative? origin raise-os-exception?)
2049 (macro-check-string path 1 (path-normalize path allow-relative? origin)
2050 (if (##eq? allow-relative? (macro-absent-obj))
2051 (##path-normalize path)
2052 (if (##eq? origin (macro-absent-obj))
2053 (##path-normalize path allow-relative?)
2054 (macro-check-string origin 2 (path-normalize path allow-relative? origin)
2055 (if (##eq? raise-os-exception? (macro-absent-obj))
2056 (##path-normalize path allow-relative? origin)
2057 (##path-normalize path allow-relative? origin raise-os-exception?))))))))
2059 (define-prim (##path-extension-start path)
2061 (##current-directory))
2062 (directory-separator
2063 (##string-ref cd (##fixnum.- (##string-length cd) 1)))
2065 (##path-volume-end-using-dir-sep path directory-separator)))
2066 (let loop ((i (##fixnum.- (##string-length path) 1)))
2067 (if (##fixnum.< vol-end i)
2068 (let ((c (##string-ref path (##fixnum.- i 1))))
2069 (cond ((or (##char=? c directory-separator)
2070 (and (##char=? #\\ directory-separator)
2072 (##string-length path))
2073 ((##char=? (##string-ref path i) #\.)
2076 (loop (##fixnum.- i 1)))))
2077 (##string-length path)))))
2079 (define-prim (##path-extension path)
2080 (##substring path (##path-extension-start path) (##string-length path)))
2082 (define-prim (path-extension path)
2083 (macro-force-vars (path)
2084 (macro-check-string path 1 (path-extension path)
2085 (##path-extension path))))
2087 (define-prim (##path-strip-extension path)
2088 (##substring path 0 (##path-extension-start path)))
2090 (define-prim (path-strip-extension path)
2091 (macro-force-vars (path)
2092 (macro-check-string path 1 (path-strip-extension path)
2093 (##path-strip-extension path))))
2095 (define-prim (##path-directory-end path)
2097 (##current-directory))
2098 (directory-separator
2099 (##string-ref cd (##fixnum.- (##string-length cd) 1)))
2101 (##path-volume-end-using-dir-sep path directory-separator)))
2102 (let loop ((i (##fixnum.- (##string-length path) 1)))
2103 (if (##fixnum.< i vol-end)
2105 (let ((c (##string-ref path i)))
2106 (cond ((or (##char=? c directory-separator)
2107 (and (##char=? #\\ directory-separator)
2111 (loop (##fixnum.- i 1)))))))))
2113 (define-prim (##path-directory path)
2114 (##substring path 0 (##path-directory-end path)))
2116 (define-prim (path-directory path)
2117 (macro-force-vars (path)
2118 (macro-check-string path 1 (path-directory path)
2119 (##path-directory path))))
2121 (define-prim (##path-strip-directory path)
2122 (##substring path (##path-directory-end path) (##string-length path)))
2124 (define-prim (path-strip-directory path)
2125 (macro-force-vars (path)
2126 (macro-check-string path 1 (path-strip-directory path)
2127 (##path-strip-directory path))))
2129 (define-prim (##path-strip-trailing-directory-separator path)
2131 (##current-directory))
2132 (directory-separator
2133 (##string-ref cd (##fixnum.- (##string-length cd) 1)))
2135 (##string-length path)))
2136 (if (and (##fixnum.< 0 len)
2137 (let ((c (##string-ref path (##fixnum.- len 1))))
2138 (or (##char=? c directory-separator)
2139 (and (##char=? #\\ directory-separator)
2140 (##char=? #\/ c)))))
2141 (##substring path 0 (##fixnum.- len 1))
2144 (define-prim (path-strip-trailing-directory-separator path)
2145 (macro-force-vars (path)
2146 (macro-check-string path 1 (path-strip-trailing-directory-separator path)
2147 (##path-strip-trailing-directory-separator path))))
2149 (define-prim (##path-volume-end path)
2151 (##current-directory))
2152 (directory-separator
2153 (##string-ref cd (##fixnum.- (##string-length cd) 1)))
2155 (##path-volume-end-using-dir-sep path directory-separator)))
2158 (define-prim (##path-volume path)
2159 (##substring path 0 (##path-volume-end path)))
2161 (define-prim (path-volume path)
2162 (macro-force-vars (path)
2163 (macro-check-string path 1 (path-volume path)
2164 (##path-volume path))))
2166 (define-prim (##path-strip-volume path)
2167 (##substring path (##path-volume-end path) (##string-length path)))
2169 (define-prim (path-strip-volume path)
2170 (macro-force-vars (path)
2171 (macro-check-string path 1 (path-strip-volume path)
2172 (##path-strip-volume path))))
2174 ;;;----------------------------------------------------------------------------
2176 ;;; Filesystem operations.
2178 (define-prim (##create-directory-or-fifo prim path-or-settings)
2181 (##fail-check-string-or-settings 1 prim path-or-settings))
2184 (macro-direction-inout)
2187 (cond ((##string? path-or-settings)
2188 (##list 'path: path-or-settings))
2194 (macro-psettings-path psettings)))
2195 (if (##not (##string? path))
2197 (let* ((resolved-path
2198 (##path-resolve path))
2200 (##psettings->permissions
2202 (if (##eq? prim create-directory)
2206 (if (##eq? prim create-directory)
2207 (##os-create-directory resolved-path permissions)
2208 (##os-create-fifo resolved-path permissions))))
2209 (if (##fixnum.< code 0)
2210 (##raise-os-exception #f code prim path-or-settings)
2213 (define-prim (create-directory path-or-settings)
2214 (macro-force-vars (path-or-settings)
2215 (##create-directory-or-fifo create-directory path-or-settings)))
2217 (define-prim (create-fifo path-or-settings)
2218 (macro-force-vars (path-or-settings)
2219 (##create-directory-or-fifo create-fifo path-or-settings)))
2221 (define-prim (##create-link old-path new-path)
2222 (let* ((resolved-old-path
2223 (##path-resolve old-path))
2225 (##path-resolve new-path))
2227 (##os-create-link resolved-old-path resolved-new-path)))
2228 (if (##fixnum.< code 0)
2229 (##raise-os-exception #f code create-link old-path new-path)
2232 (define-prim (create-link old-path new-path)
2233 (macro-force-vars (old-path new-path)
2234 (macro-check-string old-path 1 (create-link old-path new-path)
2235 (macro-check-string new-path 2 (create-link old-path new-path)
2236 (##create-link old-path new-path)))))
2238 (define-prim (##create-symbolic-link old-path new-path)
2239 (let* ((resolved-old-path
2240 (##path-resolve old-path))
2242 (##path-resolve new-path))
2244 (##os-create-symbolic-link resolved-old-path resolved-new-path)))
2245 (if (##fixnum.< code 0)
2246 (##raise-os-exception #f code create-symbolic-link old-path new-path)
2249 (define-prim (create-symbolic-link old-path new-path)
2250 (macro-force-vars (old-path new-path)
2251 (macro-check-string old-path 1 (create-symbolic-link old-path new-path)
2252 (macro-check-string new-path 2 (create-symbolic-link old-path new-path)
2253 (##create-symbolic-link old-path new-path)))))
2255 (define-prim (##delete-directory path)
2256 (let* ((resolved-path
2257 (##path-resolve path))
2259 (##os-delete-directory resolved-path)))
2260 (if (##fixnum.< code 0)
2261 (##raise-os-exception
2268 (define-prim (delete-directory path)
2269 (macro-force-vars (path)
2270 (macro-check-string path 1 (delete-directory path)
2271 (##delete-directory path))))
2273 (define-prim (##rename-file old-path new-path)
2274 (let* ((resolved-old-path
2275 (##path-resolve old-path))
2277 (##path-resolve new-path))
2281 resolved-new-path)))
2282 (if (##fixnum.< code 0)
2283 (##raise-os-exception
2291 (define-prim (rename-file old-path new-path)
2292 (macro-force-vars (old-path new-path)
2293 (macro-check-string old-path 1 (rename-file old-path new-path)
2294 (macro-check-string new-path 2 (rename-file old-path new-path)
2295 (##rename-file old-path new-path)))))
2297 (define-prim (##copy-file old-path new-path)
2298 (let* ((resolved-old-path
2299 (##path-resolve old-path))
2301 (##path-resolve new-path))
2305 resolved-new-path)))
2306 (if (##fixnum.< code 0)
2307 (##raise-os-exception
2315 (define-prim (copy-file old-path new-path)
2316 (macro-force-vars (old-path new-path)
2317 (macro-check-string old-path 1 (copy-file old-path new-path)
2318 (macro-check-string new-path 2 (copy-file old-path new-path)
2319 (##copy-file old-path new-path)))))
2321 (define-prim (##delete-file path)
2322 (let* ((resolved-path
2323 (##path-resolve path))
2325 (##os-delete-file resolved-path)))
2326 (if (##fixnum.< code 0)
2327 (##raise-os-exception
2334 (define-prim (delete-file path)
2335 (macro-force-vars (path)
2336 (macro-check-string path 1 (delete-file path)
2337 (##delete-file path))))
2339 (define-prim (##directory-files
2341 (path-or-settings (macro-absent-obj)))
2345 (let ((files (##read-all port ##read)))
2346 (##close-input-port port)
2351 (define-prim (directory-files
2353 (path-or-settings (macro-absent-obj)))
2354 (macro-force-vars (path-or-settings)
2355 (##directory-files path-or-settings)))
2357 ;;;----------------------------------------------------------------------------
2359 (define-runtime-macro (six.!x x)
2362 (define-runtime-macro (six.++x x)
2363 (##infix-update-in-place 'six.++x x 'six.x+y 1 #t))
2365 (define-runtime-macro (six.x++ x)
2366 (##infix-update-in-place 'six.x++ x 'six.x+y 1 #f))
2368 (define-runtime-macro (six.--x x)
2369 (##infix-update-in-place 'six.--x x 'six.x-y 1 #t))
2371 (define-runtime-macro (six.x-- x)
2372 (##infix-update-in-place 'six.x-- x 'six.x-y 1 #f))
2374 (define-runtime-macro (six.~x x)
2377 (define-runtime-macro (six.x%y x y)
2380 (define-runtime-macro (six.x*y x y)
2383 (define-runtime-macro (six.*x x)
2384 (##infix-lvalue-fetch (##list 'six.*x x)))
2386 (define-runtime-macro (six.x/y x y)
2389 (define-runtime-macro (six.x+y x y)
2392 (define-runtime-macro (six.+x x)
2395 (define-runtime-macro (six.x-y x y)
2398 (define-runtime-macro (six.-x x)
2401 (define-runtime-macro (six.x<<y x y)
2402 `(arithmetic-shift ,x ,y))
2404 (define-runtime-macro (six.x>>y x y)
2405 `(arithmetic-shift ,x (- ,y)))
2407 (define-runtime-macro (six.x<y x y)
2410 (define-runtime-macro (six.x<=y x y)
2413 (define-runtime-macro (six.x>y x y)
2416 (define-runtime-macro (six.x>=y x y)
2419 (define-runtime-macro (six.x!=y x y)
2420 `(not (equal? ,x ,y)))
2422 (define-runtime-macro (six.x==y x y)
2425 (define-runtime-macro (six.x&y x y)
2426 `(bitwise-and ,x ,y))
2428 (define-prim (##infix-id x)
2430 (let* ((first (##car x))
2432 (if (and (or (##eq? first 'six.identifier)
2433 (##eq? first 'six.prefix))
2435 (let* ((second (##car rest))
2436 (rest (##cdr rest)))
2437 (if (and (##symbol? second)
2444 (define-runtime-macro (six.&x x)
2445 (##infix-lvalue-access
2449 (lambda (prepare fetch only-fetch store only-store)
2450 (let* ((set (##gensym))
2455 (let ((,val (##car ,set)))
2460 (define-prim (##infix-lvalue-access form-name args x cont)
2463 (##ill-formed-special-form form-name args))
2466 (let* ((first (##car x))
2469 (let* ((second (##car rest))
2470 (rest (##cdr rest)))
2471 (cond ((##pair? rest)
2472 (let* ((third (##car rest))
2473 (rest (##cdr rest)))
2474 (cond ((##not (##null? rest))
2476 ((##eq? first 'six.index)
2477 (let* ((vect (##gensym))
2479 (cont (lambda (body)
2480 `(let ((,vect ,second) (,index ,third))
2483 `(vector-ref ,vect ,index))
2485 `(vector-ref ,second ,third))
2487 `(vector-set! ,vect ,index ,val))
2489 `(vector-set! ,second ,third ,val)))))
2490 ((and (or (##eq? first 'six.arrow)
2491 (##eq? first 'six.dot))
2495 (let* ((struct (##gensym))
2499 (##symbol->string id)
2501 (cont (lambda (body)
2502 `(let ((,struct ,second))
2509 `(,mutator ,struct ,val))
2511 `(,mutator ,second ,val))))))
2515 (cond ((##eq? first 'six.*x)
2516 (let ((ptr (##gensym)))
2517 (cont (lambda (body)
2518 `(let ((,ptr ,second))
2528 ((and (or (##eq? first 'six.identifier)
2529 (##eq? first 'six.prefix))
2531 (let ((var (##gensym)))
2532 (cont (lambda (body)
2539 `(set! ,second ,val))
2541 `(set! ,second ,val)))))
2549 (define-prim (##infix-lvalue-fetch form)
2550 (##infix-lvalue-access
2554 (lambda (prepare fetch only-fetch store only-store)
2557 (define-prim (##infix-update-in-place form-name x operator operand2 pre?)
2558 (##infix-lvalue-access
2560 (if (##eq? operand2 1)
2562 (##list x operand2))
2564 (lambda (prepare fetch only-fetch store only-store)
2565 (let ((val (##gensym)))
2568 `(let ((,val (,operator ,(fetch) ,operand2)))
2571 `(let ((,val ,(fetch)))
2572 ,(store `(,operator ,val ,operand2))
2575 (define-runtime-macro (six.x^y x y)
2576 `(bitwise-xor ,x ,y))
2578 (define-runtime-macro (|six.x\|y| x y)
2579 `(bitwise-ior ,x ,y))
2581 (define-runtime-macro (six.x&&y x y)
2584 (define-runtime-macro (|six.x\|\|y| x y)
2587 (define-runtime-macro (six.x?y:z x y z)
2590 (define-runtime-macro (six.x:y x y)
2593 (define-runtime-macro (six.x%=y x y)
2594 (##infix-update-in-place 'six.x%=y x 'six.x%y y #t))
2596 (define-runtime-macro (six.x&=y x y)
2597 (##infix-update-in-place 'six.x&=y x 'six.x&y y #t))
2599 (define-runtime-macro (six.x*=y x y)
2600 (##infix-update-in-place 'six.x*=y x 'six.x*y y #t))
2602 (define-runtime-macro (six.x+=y x y)
2603 (##infix-update-in-place 'six.x+=y x 'six.x+y y #t))
2605 (define-runtime-macro (six.x-=y x y)
2606 (##infix-update-in-place 'six.x-=y x 'six.x-y y #t))
2608 (define-runtime-macro (six.x/=y x y)
2609 (##infix-update-in-place 'six.x/=y x 'six.x/y y #t))
2611 (define-runtime-macro (six.x<<=y x y)
2612 (##infix-update-in-place 'six.x<<=y x 'six.x<<y y #t))
2614 (define-runtime-macro (six.x=y x y)
2615 (##infix-lvalue-access
2619 (lambda (prepare fetch only-fetch store only-store)
2620 (let ((val (##gensym)))
2626 (define-runtime-macro (six.x>>=y x y)
2627 (##infix-update-in-place 'six.x>>=y x 'six.x>>y y #t))
2629 (define-runtime-macro (six.x^=y x y)
2630 (##infix-update-in-place 'six.x^=y x 'six.x^y y #t))
2632 (define-runtime-macro (|six.x\|=y| x y)
2633 (##infix-update-in-place '|six.x\|=y| x '|six.x\|y| y #t))
2635 (define-runtime-macro (six.x:=y x y)
2636 (##infix-lvalue-access
2640 (lambda (prepare fetch only-fetch store only-store)
2641 (let ((val (##gensym)))
2647 (define-runtime-macro (|six.x,y| x y)
2650 (define-runtime-macro (six.cons expr1 expr2)
2651 `(cons ,expr1 ,expr2))
2653 (define-runtime-macro (six.list expr1 expr2)
2654 `(cons ,expr1 ,expr2))
2656 (define-runtime-macro (six.null)
2659 (define-runtime-macro (six.new identifier . args)
2660 (cond ((##infix-id identifier)
2663 `(,(##string->symbol
2664 (##string-append "make-"
2665 (##symbol->string id)))
2668 (##ill-formed-special-form 'six.new (##cons identifier args)))))
2670 (define-runtime-macro (six.call func . args)
2673 (define-runtime-macro (six.index expr1 expr2)
2674 (##infix-lvalue-fetch (##list 'six.index expr1 expr2)))
2676 (define-runtime-macro (six.arrow expr identifier)
2677 (##infix-lvalue-fetch (##list 'six.arrow expr identifier)))
2679 (define-runtime-macro (six.dot expr identifier)
2680 (##infix-lvalue-fetch (##list 'six.dot expr identifier)))
2682 (define-runtime-macro (six.literal value)
2685 (define-runtime-macro (six.identifier identifier)
2686 (##infix-lvalue-fetch (##list 'six.identifier identifier)))
2688 (define-runtime-macro (six.prefix datum)
2691 (define-runtime-macro (six.if expr stat1 . stat2)
2692 `(if ,expr ,stat1 ,@stat2))
2694 (define-runtime-macro (six.while expr stat)
2695 (let ((loop (gensym)))
2696 `(let ,loop () (if ,expr (begin ,stat (,loop))))))
2698 (define-runtime-macro (six.do-while stat expr)
2699 (let ((loop (gensym)))
2700 `(let ,loop () (begin ,stat (if ,expr (,loop))))))
2702 (define-runtime-macro (six.for stat1 expr2 expr3 stat2)
2703 (if (##equal? stat1 '(six.compound))
2704 (let* ((loop (gensym))
2705 (body `(begin ,stat2 ,@(if expr3 `(,expr3) '()) (,loop))))
2712 (six.for (six.compound) ,expr2 ,expr3 ,stat2))))
2714 (define-runtime-macro (six.compound . stats)
2715 (##infix-compound-expand 'six.compound stats))
2717 (define-runtime-macro (six.procedure-body . stats)
2718 (##infix-compound-expand 'six.procedure-body stats))
2720 (define-prim (##infix-compound-expand form-name stats)
2722 (define (expand lst1 lst2 first?)
2723 (cond ((##pair? lst1)
2724 (let ((stat (##car lst1)))
2725 (cond ((and (##pair? stat)
2726 (##eq? (##car stat) 'six.define-procedure))
2727 (expand (##cdr lst1)
2730 ((##not (##null? lst2))
2731 `((let () ,@(##reverse lst2) ,@(expand lst1 '() #t))))
2732 ((##infix-variable-binding stat)
2735 `((let (,binding) ,@(expand (##cdr lst1) '() #t)))))
2736 ((##null? (##cdr lst1))
2737 (if (and (##eq? form-name 'six.procedure-body)
2739 (##eq? (##car stat) 'six.return))
2740 (let ((rest (##cdr stat)))
2741 (cond ((##null? rest)
2743 ((and (##pair? rest)
2744 (##null? (##cdr rest)))
2750 `(,stat ,@(expand (##cdr lst1) '() #f))))))
2758 `(begin ,@(expand stats '() #t))))
2760 (define-runtime-macro (six.define-variable identifier type dims init)
2761 (cond ((##infix-variable-binding
2762 `(six.define-variable ,identifier ,type ,dims ,init))
2765 `(define ,@binding)))
2767 (##ill-formed-special-form 'six.define-variable
2773 (define-prim (##infix-variable-binding form)
2774 (if (and (##pair? form)
2775 (##eq? (##car form) 'six.define-variable))
2776 (let ((rest (##cdr form)))
2778 (let* ((identifier (##car rest))
2779 (rest (##cdr rest)))
2781 (let* ((type (##car rest))
2782 (rest (##cdr rest)))
2784 (let* ((dims (##car rest))
2785 (rest (##cdr rest)))
2787 (let* ((init (##car rest))
2788 (rest (##cdr rest)))
2789 (cond ((and (##null? rest)
2790 (##infix-id identifier))
2796 `(six.make-array ,init ,@dims)))))
2805 (define-prim (six.make-array init . dims)
2808 (let loop1 ((lst dims) (i 2))
2809 (let ((dim1 (##car lst)))
2810 (macro-check-index dim1 i (six.make-array init . dims)
2811 (let* ((array (##make-vector dim1 init))
2814 (let loop2 ((j (##fixnum.- dim1 1)))
2815 (if (##fixnum.< j 0)
2818 (##vector-set! array j (loop1 rest (##fixnum.+ i 1)))
2819 (loop2 (##fixnum.- j 1)))))
2824 (define-runtime-macro (six.define-procedure identifier proc)
2825 `(define ,(##infix-id identifier) ,proc))
2827 (define-runtime-macro (six.procedure type params stat)
2828 `(lambda ,(##map (lambda (x) (##infix-id (##car x))) params)
2831 ;; There is no predefined semantics for the following infix forms:
2833 ;; (define-runtime-macro (six.label identifier stat)
2836 ;; (define-runtime-macro (six.goto expr)
2839 ;; (define-runtime-macro (six.switch expr stat)
2842 ;; (define-runtime-macro (six.case expr stat)
2845 ;; (define-runtime-macro (six.break)
2848 ;; (define-runtime-macro (six.continue)
2851 ;; (define-runtime-macro (six.return . expr)
2854 ;; (define-runtime-macro (six.clause expr)
2857 ;; (define-runtime-macro (six.x:-y x y)
2860 ;; (define-runtime-macro (six.!)
2863 ;;;----------------------------------------------------------------------------
2865 ;;; Object encoding/decoding.
2867 (define-prim (##object->encoding obj)
2868 (let* ((hi (##type-cast obj (macro-type-fixnum)))
2870 (##+ (##* (if (##fixnum.< hi 0) (##- hi ##bignum.2*min-fixnum) hi)
2874 (define-prim (##encoding->object encoding)
2875 (let* ((hi (##quotient encoding 4))
2876 (lo (##modulo encoding 4))
2877 (x (if (##fixnum? hi) hi (##+ hi ##bignum.2*min-fixnum))))
2878 (##type-cast x lo)))
2880 ;;;============================================================================