-
+ 816C72CA3FE3ED9F9A2C1C1E779ADCA1279EDABAF547E70D5BBEBD00300C2062D7C2BA51A3ED200472639640577FB3643D780E204546ACA62807978BA3F54449bitcoin/src/shiva/init.scm(0 . 0)(1 . 716)
767 ; Initialization file for TinySCHEME 1.41
768
769 ; Per R5RS, up to four deep compositions should be defined
770 (define (caar x) (car (car x)))
771 (define (cadr x) (car (cdr x)))
772 (define (cdar x) (cdr (car x)))
773 (define (cddr x) (cdr (cdr x)))
774 (define (caaar x) (car (car (car x))))
775 (define (caadr x) (car (car (cdr x))))
776 (define (cadar x) (car (cdr (car x))))
777 (define (caddr x) (car (cdr (cdr x))))
778 (define (cdaar x) (cdr (car (car x))))
779 (define (cdadr x) (cdr (car (cdr x))))
780 (define (cddar x) (cdr (cdr (car x))))
781 (define (cdddr x) (cdr (cdr (cdr x))))
782 (define (caaaar x) (car (car (car (car x)))))
783 (define (caaadr x) (car (car (car (cdr x)))))
784 (define (caadar x) (car (car (cdr (car x)))))
785 (define (caaddr x) (car (car (cdr (cdr x)))))
786 (define (cadaar x) (car (cdr (car (car x)))))
787 (define (cadadr x) (car (cdr (car (cdr x)))))
788 (define (caddar x) (car (cdr (cdr (car x)))))
789 (define (cadddr x) (car (cdr (cdr (cdr x)))))
790 (define (cdaaar x) (cdr (car (car (car x)))))
791 (define (cdaadr x) (cdr (car (car (cdr x)))))
792 (define (cdadar x) (cdr (car (cdr (car x)))))
793 (define (cdaddr x) (cdr (car (cdr (cdr x)))))
794 (define (cddaar x) (cdr (cdr (car (car x)))))
795 (define (cddadr x) (cdr (cdr (car (cdr x)))))
796 (define (cdddar x) (cdr (cdr (cdr (car x)))))
797 (define (cddddr x) (cdr (cdr (cdr (cdr x)))))
798
799 ;;;; Utility to ease macro creation
800 (define (macro-expand form)
801 ((eval (get-closure-code (eval (car form)))) form))
802
803 (define (macro-expand-all form)
804 (if (macro? form)
805 (macro-expand-all (macro-expand form))
806 form))
807
808 (define *compile-hook* macro-expand-all)
809
810
811 (macro (unless form)
812 `(if (not ,(cadr form)) (begin ,@(cddr form))))
813
814 (macro (when form)
815 `(if ,(cadr form) (begin ,@(cddr form))))
816
817 ; DEFINE-MACRO Contributed by Andy Gaynor
818 (macro (define-macro dform)
819 (if (symbol? (cadr dform))
820 `(macro ,@(cdr dform))
821 (let ((form (gensym)))
822 `(macro (,(caadr dform) ,form)
823 (apply (lambda ,(cdadr dform) ,@(cddr dform)) (cdr ,form))))))
824
825 ; Utilities for math. Notice that inexact->exact is primitive,
826 ; but exact->inexact is not.
827 (define exact? integer?)
828 (define (inexact? x) (and (real? x) (not (integer? x))))
829 (define (even? n) (= (remainder n 2) 0))
830 (define (odd? n) (not (= (remainder n 2) 0)))
831 (define (zero? n) (= n 0))
832 (define (positive? n) (> n 0))
833 (define (negative? n) (< n 0))
834 (define complex? number?)
835 (define rational? real?)
836 (define (abs n) (if (>= n 0) n (- n)))
837 (define (exact->inexact n) (* n 1.0))
838 (define (<> n1 n2) (not (= n1 n2)))
839
840 ; min and max must return inexact if any arg is inexact; use (+ n 0.0)
841 (define (max . lst)
842 (foldr (lambda (a b)
843 (if (> a b)
844 (if (exact? b) a (+ a 0.0))
845 (if (exact? a) b (+ b 0.0))))
846 (car lst) (cdr lst)))
847 (define (min . lst)
848 (foldr (lambda (a b)
849 (if (< a b)
850 (if (exact? b) a (+ a 0.0))
851 (if (exact? a) b (+ b 0.0))))
852 (car lst) (cdr lst)))
853
854 (define (succ x) (+ x 1))
855 (define (pred x) (- x 1))
856 (define gcd
857 (lambda a
858 (if (null? a)
859 0
860 (let ((aa (abs (car a)))
861 (bb (abs (cadr a))))
862 (if (= bb 0)
863 aa
864 (gcd bb (remainder aa bb)))))))
865 (define lcm
866 (lambda a
867 (if (null? a)
868 1
869 (let ((aa (abs (car a)))
870 (bb (abs (cadr a))))
871 (if (or (= aa 0) (= bb 0))
872 0
873 (abs (* (quotient aa (gcd aa bb)) bb)))))))
874
875
876 (define (string . charlist)
877 (list->string charlist))
878
879 (define (list->string charlist)
880 (let* ((len (length charlist))
881 (newstr (make-string len))
882 (fill-string!
883 (lambda (str i len charlist)
884 (if (= i len)
885 str
886 (begin (string-set! str i (car charlist))
887 (fill-string! str (+ i 1) len (cdr charlist)))))))
888 (fill-string! newstr 0 len charlist)))
889
890 (define (string-fill! s e)
891 (let ((n (string-length s)))
892 (let loop ((i 0))
893 (if (= i n)
894 s
895 (begin (string-set! s i e) (loop (succ i)))))))
896
897 (define (string->list s)
898 (let loop ((n (pred (string-length s))) (l '()))
899 (if (= n -1)
900 l
901 (loop (pred n) (cons (string-ref s n) l)))))
902
903 (define (string-copy str)
904 (string-append str))
905
906 (define (string->anyatom str pred)
907 (let* ((a (string->atom str)))
908 (if (pred a) a
909 (error "string->xxx: not a xxx" a))))
910
911 (define (string->number str . base)
912 (let ((n (string->atom str (if (null? base) 10 (car base)))))
913 (if (number? n) n #f)))
914
915 (define (anyatom->string n pred)
916 (if (pred n)
917 (atom->string n)
918 (error "xxx->string: not a xxx" n)))
919
920 (define (number->string n . base)
921 (atom->string n (if (null? base) 10 (car base))))
922
923
924 (define (char-cmp? cmp a b)
925 (cmp (char->integer a) (char->integer b)))
926 (define (char-ci-cmp? cmp a b)
927 (cmp (char->integer (char-downcase a)) (char->integer (char-downcase b))))
928
929 (define (char=? a b) (char-cmp? = a b))
930 (define (char<? a b) (char-cmp? < a b))
931 (define (char>? a b) (char-cmp? > a b))
932 (define (char<=? a b) (char-cmp? <= a b))
933 (define (char>=? a b) (char-cmp? >= a b))
934
935 (define (char-ci=? a b) (char-ci-cmp? = a b))
936 (define (char-ci<? a b) (char-ci-cmp? < a b))
937 (define (char-ci>? a b) (char-ci-cmp? > a b))
938 (define (char-ci<=? a b) (char-ci-cmp? <= a b))
939 (define (char-ci>=? a b) (char-ci-cmp? >= a b))
940
941 ; Note the trick of returning (cmp x y)
942 (define (string-cmp? chcmp cmp a b)
943 (let ((na (string-length a)) (nb (string-length b)))
944 (let loop ((i 0))
945 (cond
946 ((= i na)
947 (if (= i nb) (cmp 0 0) (cmp 0 1)))
948 ((= i nb)
949 (cmp 1 0))
950 ((chcmp = (string-ref a i) (string-ref b i))
951 (loop (succ i)))
952 (else
953 (chcmp cmp (string-ref a i) (string-ref b i)))))))
954
955
956 (define (string=? a b) (string-cmp? char-cmp? = a b))
957 (define (string<? a b) (string-cmp? char-cmp? < a b))
958 (define (string>? a b) (string-cmp? char-cmp? > a b))
959 (define (string<=? a b) (string-cmp? char-cmp? <= a b))
960 (define (string>=? a b) (string-cmp? char-cmp? >= a b))
961
962 (define (string-ci=? a b) (string-cmp? char-ci-cmp? = a b))
963 (define (string-ci<? a b) (string-cmp? char-ci-cmp? < a b))
964 (define (string-ci>? a b) (string-cmp? char-ci-cmp? > a b))
965 (define (string-ci<=? a b) (string-cmp? char-ci-cmp? <= a b))
966 (define (string-ci>=? a b) (string-cmp? char-ci-cmp? >= a b))
967
968 (define (list . x) x)
969
970 (define (foldr f x lst)
971 (if (null? lst)
972 x
973 (foldr f (f x (car lst)) (cdr lst))))
974
975 (define (unzip1-with-cdr . lists)
976 (unzip1-with-cdr-iterative lists '() '()))
977
978 (define (unzip1-with-cdr-iterative lists cars cdrs)
979 (if (null? lists)
980 (cons cars cdrs)
981 (let ((car1 (caar lists))
982 (cdr1 (cdar lists)))
983 (unzip1-with-cdr-iterative
984 (cdr lists)
985 (append cars (list car1))
986 (append cdrs (list cdr1))))))
987
988 (define (map proc . lists)
989 (if (null? lists)
990 (apply proc)
991 (if (null? (car lists))
992 '()
993 (let* ((unz (apply unzip1-with-cdr lists))
994 (cars (car unz))
995 (cdrs (cdr unz)))
996 (cons (apply proc cars) (apply map (cons proc cdrs)))))))
997
998 (define (for-each proc . lists)
999 (if (null? lists)
1000 (apply proc)
1001 (if (null? (car lists))
1002 #t
1003 (let* ((unz (apply unzip1-with-cdr lists))
1004 (cars (car unz))
1005 (cdrs (cdr unz)))
1006 (apply proc cars) (apply map (cons proc cdrs))))))
1007
1008 (define (list-tail x k)
1009 (if (zero? k)
1010 x
1011 (list-tail (cdr x) (- k 1))))
1012
1013 (define (list-ref x k)
1014 (car (list-tail x k)))
1015
1016 (define (last-pair x)
1017 (if (pair? (cdr x))
1018 (last-pair (cdr x))
1019 x))
1020
1021 (define (head stream) (car stream))
1022
1023 (define (tail stream) (force (cdr stream)))
1024
1025 (define (vector-equal? x y)
1026 (and (vector? x) (vector? y) (= (vector-length x) (vector-length y))
1027 (let ((n (vector-length x)))
1028 (let loop ((i 0))
1029 (if (= i n)
1030 #t
1031 (and (equal? (vector-ref x i) (vector-ref y i))
1032 (loop (succ i))))))))
1033
1034 (define (list->vector x)
1035 (apply vector x))
1036
1037 (define (vector-fill! v e)
1038 (let ((n (vector-length v)))
1039 (let loop ((i 0))
1040 (if (= i n)
1041 v
1042 (begin (vector-set! v i e) (loop (succ i)))))))
1043
1044 (define (vector->list v)
1045 (let loop ((n (pred (vector-length v))) (l '()))
1046 (if (= n -1)
1047 l
1048 (loop (pred n) (cons (vector-ref v n) l)))))
1049
1050 ;; The following quasiquote macro is due to Eric S. Tiedemann.
1051 ;; Copyright 1988 by Eric S. Tiedemann; all rights reserved.
1052 ;;
1053 ;; Subsequently modified to handle vectors: D. Souflis
1054
1055 (macro
1056 quasiquote
1057 (lambda (l)
1058 (define (mcons f l r)
1059 (if (and (pair? r)
1060 (eq? (car r) 'quote)
1061 (eq? (car (cdr r)) (cdr f))
1062 (pair? l)
1063 (eq? (car l) 'quote)
1064 (eq? (car (cdr l)) (car f)))
1065 (if (or (procedure? f) (number? f) (string? f))
1066 f
1067 (list 'quote f))
1068 (if (eqv? l vector)
1069 (apply l (eval r))
1070 (list 'cons l r)
1071 )))
1072 (define (mappend f l r)
1073 (if (or (null? (cdr f))
1074 (and (pair? r)
1075 (eq? (car r) 'quote)
1076 (eq? (car (cdr r)) '())))
1077 l
1078 (list 'append l r)))
1079 (define (foo level form)
1080 (cond ((not (pair? form))
1081 (if (or (procedure? form) (number? form) (string? form))
1082 form
1083 (list 'quote form))
1084 )
1085 ((eq? 'quasiquote (car form))
1086 (mcons form ''quasiquote (foo (+ level 1) (cdr form))))
1087 (#t (if (zero? level)
1088 (cond ((eq? (car form) 'unquote) (car (cdr form)))
1089 ((eq? (car form) 'unquote-splicing)
1090 (error "Unquote-splicing wasn't in a list:"
1091 form))
1092 ((and (pair? (car form))
1093 (eq? (car (car form)) 'unquote-splicing))
1094 (mappend form (car (cdr (car form)))
1095 (foo level (cdr form))))
1096 (#t (mcons form (foo level (car form))
1097 (foo level (cdr form)))))
1098 (cond ((eq? (car form) 'unquote)
1099 (mcons form ''unquote (foo (- level 1)
1100 (cdr form))))
1101 ((eq? (car form) 'unquote-splicing)
1102 (mcons form ''unquote-splicing
1103 (foo (- level 1) (cdr form))))
1104 (#t (mcons form (foo level (car form))
1105 (foo level (cdr form)))))))))
1106 (foo 0 (car (cdr l)))))
1107
1108 ;;;;;Helper for the dynamic-wind definition. By Tom Breton (Tehom)
1109 (define (shared-tail x y)
1110 (let ((len-x (length x))
1111 (len-y (length y)))
1112 (define (shared-tail-helper x y)
1113 (if
1114 (eq? x y)
1115 x
1116 (shared-tail-helper (cdr x) (cdr y))))
1117
1118 (cond
1119 ((> len-x len-y)
1120 (shared-tail-helper
1121 (list-tail x (- len-x len-y))
1122 y))
1123 ((< len-x len-y)
1124 (shared-tail-helper
1125 x
1126 (list-tail y (- len-y len-x))))
1127 (#t (shared-tail-helper x y)))))
1128
1129 ;;;;;Dynamic-wind by Tom Breton (Tehom)
1130
1131 ;;Guarded because we must only eval this once, because doing so
1132 ;;redefines call/cc in terms of old call/cc
1133 (unless (defined? 'dynamic-wind)
1134 (let
1135 ;;These functions are defined in the context of a private list of
1136 ;;pairs of before/after procs.
1137 ( (*active-windings* '())
1138 ;;We'll define some functions into the larger environment, so
1139 ;;we need to know it.
1140 (outer-env (current-environment)))
1141
1142 ;;Poor-man's structure operations
1143 (define before-func car)
1144 (define after-func cdr)
1145 (define make-winding cons)
1146
1147 ;;Manage active windings
1148 (define (activate-winding! new)
1149 ((before-func new))
1150 (set! *active-windings* (cons new *active-windings*)))
1151 (define (deactivate-top-winding!)
1152 (let ((old-top (car *active-windings*)))
1153 ;;Remove it from the list first so it's not active during its
1154 ;;own exit.
1155 (set! *active-windings* (cdr *active-windings*))
1156 ((after-func old-top))))
1157
1158 (define (set-active-windings! new-ws)
1159 (unless (eq? new-ws *active-windings*)
1160 (let ((shared (shared-tail new-ws *active-windings*)))
1161
1162 ;;Define the looping functions.
1163 ;;Exit the old list. Do deeper ones last. Don't do
1164 ;;any shared ones.
1165 (define (pop-many)
1166 (unless (eq? *active-windings* shared)
1167 (deactivate-top-winding!)
1168 (pop-many)))
1169 ;;Enter the new list. Do deeper ones first so that the
1170 ;;deeper windings will already be active. Don't do any
1171 ;;shared ones.
1172 (define (push-many new-ws)
1173 (unless (eq? new-ws shared)
1174 (push-many (cdr new-ws))
1175 (activate-winding! (car new-ws))))
1176
1177 ;;Do it.
1178 (pop-many)
1179 (push-many new-ws))))
1180
1181 ;;The definitions themselves.
1182 (eval
1183 `(define call-with-current-continuation
1184 ;;It internally uses the built-in call/cc, so capture it.
1185 ,(let ((old-c/cc call-with-current-continuation))
1186 (lambda (func)
1187 ;;Use old call/cc to get the continuation.
1188 (old-c/cc
1189 (lambda (continuation)
1190 ;;Call func with not the continuation itself
1191 ;;but a procedure that adjusts the active
1192 ;;windings to what they were when we made
1193 ;;this, and only then calls the
1194 ;;continuation.
1195 (func
1196 (let ((current-ws *active-windings*))
1197 (lambda (x)
1198 (set-active-windings! current-ws)
1199 (continuation x)))))))))
1200 outer-env)
1201 ;;We can't just say "define (dynamic-wind before thunk after)"
1202 ;;because the lambda it's defined to lives in this environment,
1203 ;;not in the global environment.
1204 (eval
1205 `(define dynamic-wind
1206 ,(lambda (before thunk after)
1207 ;;Make a new winding
1208 (activate-winding! (make-winding before after))
1209 (let ((result (thunk)))
1210 ;;Get rid of the new winding.
1211 (deactivate-top-winding!)
1212 ;;The return value is that of thunk.
1213 result)))
1214 outer-env)))
1215
1216 (define call/cc call-with-current-continuation)
1217
1218
1219 ;;;;; atom? and equal? written by a.k
1220
1221 ;;;; atom?
1222 (define (atom? x)
1223 (not (pair? x)))
1224
1225 ;;;; equal?
1226 (define (equal? x y)
1227 (cond
1228 ((pair? x)
1229 (and (pair? y)
1230 (equal? (car x) (car y))
1231 (equal? (cdr x) (cdr y))))
1232 ((vector? x)
1233 (and (vector? y) (vector-equal? x y)))
1234 ((string? x)
1235 (and (string? y) (string=? x y)))
1236 (else (eqv? x y))))
1237
1238 ;;;; (do ((var init inc) ...) (endtest result ...) body ...)
1239 ;;
1240 (macro do
1241 (lambda (do-macro)
1242 (apply (lambda (do vars endtest . body)
1243 (let ((do-loop (gensym)))
1244 `(letrec ((,do-loop
1245 (lambda ,(map (lambda (x)
1246 (if (pair? x) (car x) x))
1247 `,vars)
1248 (if ,(car endtest)
1249 (begin ,@(cdr endtest))
1250 (begin
1251 ,@body
1252 (,do-loop
1253 ,@(map (lambda (x)
1254 (cond
1255 ((not (pair? x)) x)
1256 ((< (length x) 3) (car x))
1257 (else (car (cdr (cdr x))))))
1258 `,vars)))))))
1259 (,do-loop
1260 ,@(map (lambda (x)
1261 (if (and (pair? x) (cdr x))
1262 (car (cdr x))
1263 '()))
1264 `,vars)))))
1265 do-macro)))
1266
1267 ;;;; generic-member
1268 (define (generic-member cmp obj lst)
1269 (cond
1270 ((null? lst) #f)
1271 ((cmp obj (car lst)) lst)
1272 (else (generic-member cmp obj (cdr lst)))))
1273
1274 (define (memq obj lst)
1275 (generic-member eq? obj lst))
1276 (define (memv obj lst)
1277 (generic-member eqv? obj lst))
1278 (define (member obj lst)
1279 (generic-member equal? obj lst))
1280
1281 ;;;; generic-assoc
1282 (define (generic-assoc cmp obj alst)
1283 (cond
1284 ((null? alst) #f)
1285 ((cmp obj (caar alst)) (car alst))
1286 (else (generic-assoc cmp obj (cdr alst)))))
1287
1288 (define (assq obj alst)
1289 (generic-assoc eq? obj alst))
1290 (define (assv obj alst)
1291 (generic-assoc eqv? obj alst))
1292 (define (assoc obj alst)
1293 (generic-assoc equal? obj alst))
1294
1295 (define (acons x y z) (cons (cons x y) z))
1296
1297 ;;;; Handy for imperative programs
1298 ;;;; Used as: (define-with-return (foo x y) .... (return z) ...)
1299 (macro (define-with-return form)
1300 `(define ,(cadr form)
1301 (call/cc (lambda (return) ,@(cddr form)))))
1302
1303 ;;;; Simple exception handling
1304 ;
1305 ; Exceptions are caught as follows:
1306 ;
1307 ; (catch (do-something to-recover and-return meaningful-value)
1308 ; (if-something goes-wrong)
1309 ; (with-these calls))
1310 ;
1311 ; "Catch" establishes a scope spanning multiple call-frames
1312 ; until another "catch" is encountered.
1313 ;
1314 ; Exceptions are thrown with:
1315 ;
1316 ; (throw "message")
1317 ;
1318 ; If used outside a (catch ...), reverts to (error "message)
1319
1320 (define *handlers* (list))
1321
1322 (define (push-handler proc)
1323 (set! *handlers* (cons proc *handlers*)))
1324
1325 (define (pop-handler)
1326 (let ((h (car *handlers*)))
1327 (set! *handlers* (cdr *handlers*))
1328 h))
1329
1330 (define (more-handlers?)
1331 (pair? *handlers*))
1332
1333 (define (throw . x)
1334 (if (more-handlers?)
1335 (apply (pop-handler))
1336 (apply error x)))
1337
1338 (macro (catch form)
1339 (let ((label (gensym)))
1340 `(call/cc (lambda (exit)
1341 (push-handler (lambda () (exit ,(cadr form))))
1342 (let ((,label (begin ,@(cddr form))))
1343 (pop-handler)
1344 ,label)))))
1345
1346 (define *error-hook* throw)
1347
1348
1349 ;;;;; Definition of MAKE-ENVIRONMENT, to be used with two-argument EVAL
1350
1351 (macro (make-environment form)
1352 `(apply (lambda ()
1353 ,@(cdr form)
1354 (current-environment))))
1355
1356 (define-macro (eval-polymorphic x . envl)
1357 (display envl)
1358 (let* ((env (if (null? envl) (current-environment) (eval (car envl))))
1359 (xval (eval x env)))
1360 (if (closure? xval)
1361 (make-closure (get-closure-code xval) env)
1362 xval)))
1363
1364 ; Redefine this if you install another package infrastructure
1365 ; Also redefine 'package'
1366 (define *colon-hook* eval)
1367
1368 ;;;;; I/O
1369
1370 (define (input-output-port? p)
1371 (and (input-port? p) (output-port? p)))
1372
1373 (define (close-port p)
1374 (cond
1375 ((input-output-port? p) (close-input-port (close-output-port p)))
1376 ((input-port? p) (close-input-port p))
1377 ((output-port? p) (close-output-port p))
1378 (else (throw "Not a port" p))))
1379
1380 (define (call-with-input-file s p)
1381 (let ((inport (open-input-file s)))
1382 (if (eq? inport #f)
1383 #f
1384 (let ((res (p inport)))
1385 (close-input-port inport)
1386 res))))
1387
1388 (define (call-with-output-file s p)
1389 (let ((outport (open-output-file s)))
1390 (if (eq? outport #f)
1391 #f
1392 (let ((res (p outport)))
1393 (close-output-port outport)
1394 res))))
1395
1396 (define (with-input-from-file s p)
1397 (let ((inport (open-input-file s)))
1398 (if (eq? inport #f)
1399 #f
1400 (let ((prev-inport (current-input-port)))
1401 (set-input-port inport)
1402 (let ((res (p)))
1403 (close-input-port inport)
1404 (set-input-port prev-inport)
1405 res)))))
1406
1407 (define (with-output-to-file s p)
1408 (let ((outport (open-output-file s)))
1409 (if (eq? outport #f)
1410 #f
1411 (let ((prev-outport (current-output-port)))
1412 (set-output-port outport)
1413 (let ((res (p)))
1414 (close-output-port outport)
1415 (set-output-port prev-outport)
1416 res)))))
1417
1418 (define (with-input-output-from-to-files si so p)
1419 (let ((inport (open-input-file si))
1420 (outport (open-input-file so)))
1421 (if (not (and inport outport))
1422 (begin
1423 (close-input-port inport)
1424 (close-output-port outport)
1425 #f)
1426 (let ((prev-inport (current-input-port))
1427 (prev-outport (current-output-port)))
1428 (set-input-port inport)
1429 (set-output-port outport)
1430 (let ((res (p)))
1431 (close-input-port inport)
1432 (close-output-port outport)
1433 (set-input-port prev-inport)
1434 (set-output-port prev-outport)
1435 res)))))
1436
1437 ; Random number generator (maximum cycle)
1438 (define *seed* 1)
1439 (define (random-next)
1440 (let* ((a 16807) (m 2147483647) (q (quotient m a)) (r (modulo m a)))
1441 (set! *seed*
1442 (- (* a (- *seed*
1443 (* (quotient *seed* q) q)))
1444 (* (quotient *seed* q) r)))
1445 (if (< *seed* 0) (set! *seed* (+ *seed* m)))
1446 *seed*))
1447 ;; SRFI-0
1448 ;; COND-EXPAND
1449 ;; Implemented as a macro
1450 (define *features* '(srfi-0))
1451
1452 (define-macro (cond-expand . cond-action-list)
1453 (cond-expand-runtime cond-action-list))
1454
1455 (define (cond-expand-runtime cond-action-list)
1456 (if (null? cond-action-list)
1457 #t
1458 (if (cond-eval (caar cond-action-list))
1459 `(begin ,@(cdar cond-action-list))
1460 (cond-expand-runtime (cdr cond-action-list)))))
1461
1462 (define (cond-eval-and cond-list)
1463 (foldr (lambda (x y) (and (cond-eval x) (cond-eval y))) #t cond-list))
1464
1465 (define (cond-eval-or cond-list)
1466 (foldr (lambda (x y) (or (cond-eval x) (cond-eval y))) #f cond-list))
1467
1468 (define (cond-eval condition)
1469 (cond
1470 ((symbol? condition)
1471 (if (member condition *features*) #t #f))
1472 ((eq? condition #t) #t)
1473 ((eq? condition #f) #f)
1474 (else (case (car condition)
1475 ((and) (cond-eval-and (cdr condition)))
1476 ((or) (cond-eval-or (cdr condition)))
1477 ((not) (if (not (null? (cddr condition)))
1478 (error "cond-expand : 'not' takes 1 argument")
1479 (not (cond-eval (cadr condition)))))
1480 (else (error "cond-expand : unknown operator" (car condition)))))))
1481
1482 (gc-verbose #f)