(v7 (f v0 v1 v2 v3 v4 v5 v6))
|#
(else ((ucode-primitive apply) f a0))))))
-
+
(define (apply-entity-procedure self f . args)
self ; ignored
(apply-2 f
(if (< sl 10)
(print-medium value split-factor split-digits)
(make-power-stack value split-factor '() split-digits)))))
-
+
(cond ((not (int:integer? number))
(error:wrong-type-argument number #f 'NUMBER->STRING))
((int:negative? number)
(lambda (n e)
(flo:denormalize (integer->flonum n #b11) e))))
(step1 n d))))
-
+
(define (slow-method n d)
(if (int:positive? n)
(n>0 n d)
((ucode-primitive with-interrupt-mask)
(fix:and limit-mask (get-interrupt-enables))
procedure))
-
+\f
(define (object-constant? object)
((ucode-primitive constant?) object))
(define (run-boot-inits! environment)
(and (not (lexical-unreferenceable? environment saved-boot-inits))
(let ((inits
- ((ucode-primitive lexical-reference) environment saved-boot-inits)))
+ ((ucode-primitive lexical-reference)
+ environment
+ saved-boot-inits)))
((ucode-primitive unbind-variable) environment saved-boot-inits)
(for-each (lambda (init) (init))
inits))))
(call-with-binary-input-file (merge-pathnames ifile)
(lambda (input)
(call-with-binary-output-file (merge-pathnames ofile)
- (lambda (output)
+ (lambda (output)
(write-string "Compressed-B1-1.00" output)
(compress-ports input output))))))
(declare (usual-integrations))
\f
-#|
+#|
This macro works like the Common Lisp `defstruct' with the following
differences:
(lambda (instance)
(and (string? instance)
(>= (string-length instance) totlen)
- (substring? middle instance)))))
+ (substring? middle instance)))))
\f
(else
(let* ((prelen (string-length prefix))
(close-port port)
(set! port #f)
unspecific))))))))
-
+
(define console-channel-descriptor)
(define (cache-console-channel-descriptor!)
(lambda (port*)
(recvr
(channel-descriptor
- (port/input-channel port*))))))))
+ (port/input-channel port*))))))))
(define (with-output-channel in out)
(cond ((default-object? stderr)
;; must be quoted by another.
(char-set #\\ #\/))
-(define sub-directory-delimiter-string
+(define sub-directory-delimiter-string
"\\")
(define init-file-name "scheme.ini")
"")
((pair? directory)
(string-append
- (if (eq? (car directory) 'ABSOLUTE)
+ (if (eq? (car directory) 'ABSOLUTE)
sub-directory-delimiter-string
"")
(let loop ((directory (cdr directory)))
(try 0.00499 '(absolute -3 normal) "0.")
- (display "\n\nSuccesses: ") (display successes)
+ (display "\n\nSuccesses: ") (display successes)
(display " Failures: ") (display failures))
|#
(hook/gc-finish start-value space-remaining))
(define gc-boot-loading?)
-
+
(define gc-boot-death-message
"\n;; Aborting boot-load: Not enough memory to load -- Use -large option.\n")
\f
default/record-statistic!)
(error "Can't grab GC statistics hook"))))
unspecific))
-
+
(define (with-gc-notification! notify? thunk)
(fluid-let ((hook/record-statistic!
(if notify? gc-notification default/record-statistic!)))
#d10))
"%)")
7))))))
-
+
(string-append ";GC #"
(number->string (gc-statistic/meter statistic))
": took: "
#x0127 #x00B2 #x00B3 #x00B4 #x00B5 #x0125 #x00B7 #x00B8
#x0131 #x015F #x011F #x0135 #x00BD #f #x017C #x00C0
#x00C1 #x00C2 #f #x00C4 #x010A #x0108 #x00C7 #x00C8
- #x00C9 #x00CA #x00CB #x00CC #x00CD #x00CE #x00CF #f
+ #x00C9 #x00CA #x00CB #x00CC #x00CD #x00CE #x00CF #f
#x00D1 #x00D2 #x00D3 #x00D4 #x0120 #x00D6 #x00D7 #x011C
#x00D9 #x00DA #x00DB #x00DC #x016C #x015C #x00DF #x00E0
#x00E1 #x00E2 #f #x00E4 #x010B #x0109 #x00E7 #x00E8
- #x00E9 #x00EA #x00EB #x00EC #x00ED #x00EE #x00EF #f
+ #x00E9 #x00EA #x00EB #x00EC #x00ED #x00EE #x00EF #f
#x00F1 #x00F2 #x00F3 #x00F4 #x0121 #x00F6 #x00F7 #x011D
#x00F9 #x00FA #x00FB #x00FC #x016D #x015D #x02D9)
'(ISO_8859-5:1988 ISO-IR-144 ISO_8859-5 CYRILLIC CSISOLATINCYRILLIC))
\f
(define-8-bit-codecs iso-8859-6 #xA1
- #f #f #f #x00A4 #f #f #f #f
- #f #f #f #x060C #x00AD #f #f #f
- #f #f #f #f #f #f #f #f
- #f #f #x061B #f #f #f #x061F #f
+ #f #f #f #x00A4 #f #f #f #f
+ #f #f #f #x060C #x00AD #f #f #f
+ #f #f #f #f #f #f #f #f
+ #f #f #x061B #f #f #f #x061F #f
#x0621 #x0622 #x0623 #x0624 #x0625 #x0626 #x0627 #x0628
#x0629 #x062A #x062B #x062C #x062D #x062E #x062F #x0630
#x0631 #x0632 #x0633 #x0634 #x0635 #x0636 #x0637 #x0638
#x0639 #x063A #f #f #f #f #f #x0640
#x0641 #x0642 #x0643 #x0644 #x0645 #x0646 #x0647 #x0648
#x0649 #x064A #x064B #x064C #x064D #x064E #x064F #x0650
- #x0651 #x0652 #f #f #f #f #f #f
+ #x0651 #x0652 #f #f #f #f #f #f
#f #f #f #f #f #f #f)
(define-coding-aliases 'ISO-8859-6
#f #x00A2 #x00A3 #x00A4 #x00A5 #x00A6 #x00A7 #x00A8
#x00A9 #x00D7 #x00AB #x00AC #x00AD #x00AE #x00AF #x00B0
#x00B1 #x00B2 #x00B3 #x00B4 #x00B5 #x00B6 #x00B7 #x00B8
- #x00B9 #x00F7 #x00BB #x00BC #x00BD #x00BE #f #f
- #f #f #f #f #f #f #f #f
- #f #f #f #f #f #f #f #f
- #f #f #f #f #f #f #f #f
+ #x00B9 #x00F7 #x00BB #x00BC #x00BD #x00BE #f #f
+ #f #f #f #f #f #f #f #f
+ #f #f #f #f #f #f #f #f
+ #f #f #f #f #f #f #f #f
#f #f #f #f #f #f #x2017 #x05D0
#x05D1 #x05D2 #x05D3 #x05D4 #x05D5 #x05D6 #x05D7 #x05D8
#x05D9 #x05DA #x05DB #x05DC #x05DD #x05DE #x05DF #x05E0
(fill-from-byte-vector (operation 'fill-from-byte-vector)))
(if (not (null? operations))
(error "Extra image type operations: " operations)
- (%make-image-type create destroy
- width height
+ (%make-image-type create destroy
+ width height
draw draw-subimage fill-from-byte-vector))))))
\f
(define-structure (image (conc-name image/) (constructor %make-image))
(or (eq? x #f)
(object-hash x
(if (default-object? table) default-hash-table table)
- #f)))
+ #f)))
\f
;;; This can cons a bit when interpreted.
(define (dummy-reduction? reduction)
(and (false? (reduction-expression reduction))
(eq? (ucode-return-address pop-from-compiled-code)
- (reduction-environment reduction))))
+ (reduction-environment reduction))))
(define (record-dummy-reduction-in-history! history)
(record-evaluation-in-history!
params-are-expectation?)
write-parameters)
\f
-#;
+#;
(define-header "From"
;; parser is completely different -- it's a mail address.
...
(define (refill-input-buffer-and-retry needed)
(short-substring-move! input-buffer ip ip-end input-buffer 0)
(let* ((left (fix:- ip-end ip))
- (count (read-substring input-port input-buffer
+ (count (read-substring input-port input-buffer
left input-size))
(total (fix:+ count left)))
(if (fix:= count 0)
(define (finished)
(output-port/write-substring output-port buffer 0 bp)
bp)
-
+
(define (literal-command byte)
(let ((length (fix:+ byte 1))
(ip* (fix:+ ip 1)))
(define (uncompress-internal ifile ofile if-fail)
(call-with-binary-input-file (merge-pathnames ifile)
- (lambda (input)
+ (lambda (input)
(let* ((file-marker "Compressed-B1-1.00")
(marker-size (string-length file-marker))
(actual-marker (make-string marker-size)))
marker-size)
(string=? file-marker actual-marker))
(call-with-binary-output-file (merge-pathnames ofile)
- (lambda (output)
+ (lambda (output)
(uncompress-ports input output (fix:* (file-length ifile) 2))))
(if-fail "Not a recognized compressed file:" ifile))))))
\f
#| -*-Scheme-*-
-Copyright (C) 2010 Massachusetts Institute of Technology
+Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
+ 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
+ 2006, 2007, 2008, 2009, 2010 Massachusetts Institute of Technology
This file is part of MIT/GNU Scheme.
(declare (usual-integrations))
\f
(define (initialize-package!)
- (set! *keyword-intern-table* (make-string-hash-table)))
+ (set! *keyword-intern-table* (make-string-hash-table))
+ unspecific)
(define *keyword-intern-table*)
((BOTH CL)
(write-char #\: port)
(write (keyword/name object) port))
- ((DSSSL SRFI-88)
+ ((DSSSL SRFI-88)
(write (keyword/name object) port)
(write-char #\: port))
(else
(guarantee-string string 'string->keyword)
(or (hash-table/get *keyword-intern-table* string #f)
(let ((new-keyword (%make-keyword (string->symbol string))))
- (hash-table/put! *keyword-intern-table* (string-copy string) new-keyword)
+ (hash-table/put! *keyword-intern-table*
+ (string-copy string)
+ new-keyword)
new-keyword)))
\ No newline at end of file
(fix:xor (vector-8b-ref buf k)
(vector-ref s (inc-mod
(fix:+ (fix:1+ (vector-ref s i))
- (vector-ref s j))
+ (vector-ref s j))
ts))))
(loop (fix:1+ k) i j)))
(begin
(vector-ref '#("Mon" "Tue" "Wed" "Thu" "Fri" "Sat" "Sun")
(decoded-time/day-of-week the-time))
" "
- (vector-ref '#("Jan" "Feb" "Mar" "Apr" "May" "Jun"
+ (vector-ref '#("Jan" "Feb" "Mar" "Apr" "May" "Jun"
"Jul" "Aug" "Sep" "Oct" "Nov" "Dec")
(-1+ (decoded-time/month the-time)))
" "
description
(if (default-object? caller) #f caller)))
n))
-
+\f
(define (length list)
(guarantee-list->length list 'LENGTH))
(else (error:not-list list 'length=?))))
(define (%same-length left right)
- (cond ((pair? left) (cond ((pair? right) (%same-length (cdr left) (cdr right)))
- ((null? right) #f)
- (else (error:not-list right 'length=?))))
- ((null? left) (cond ((pair? right) #f)
- ((null? right) #t)
- (else (error:not-list right 'length=?))))
- (else (error:not-list left 'length=?))))
+ (cond ((pair? left)
+ (cond ((pair? right) (%same-length (cdr left) (cdr right)))
+ ((null? right) #f)
+ (else (error:not-list right 'length=?))))
+ ((null? left)
+ (cond ((pair? right) #f)
+ ((null? right) #t)
+ (else (error:not-list right 'length=?))))
+ (else
+ (error:not-list left 'length=?))))
;; Take arguments in either order to make this easy to use.
- (cond ((pair? left) (cond ((pair? right) (%same-length (cdr left) (cdr right)))
- ((index-fixnum? right) (%length=? right left))
- ((null? right) #F)
- (else (error:wrong-type-argument right "index fixnum or list" 'length=?))))
- ((index-fixnum? left) (%length=? left right))
- ((null? left) (cond ((pair? right) #f)
- ((index-fixnum? right) (fix:zero? right))
- ((null? right) #t)
- (else (error:wrong-type-argument right "index fixnum or list" 'length=?))))
- (else (error:wrong-type-argument left "index fixnum or list" 'length=?))))
+ (cond ((pair? left)
+ (cond ((pair? right) (%same-length (cdr left) (cdr right)))
+ ((index-fixnum? right) (%length=? right left))
+ ((null? right) #f)
+ (else
+ (error:wrong-type-argument right "index fixnum or list"
+ 'length=?))))
+ ((index-fixnum? left)
+ (%length=? left right))
+ ((null? left)
+ (cond ((pair? right) #f)
+ ((index-fixnum? right) (fix:zero? right))
+ ((null? right) #t)
+ (else
+ (error:wrong-type-argument right "index fixnum or list"
+ 'length=?))))
+ (else
+ (error:wrong-type-argument left "index fixnum or list" 'length=?))))
(define (not-pair? x)
(not (pair? x)))
(RUNTIME TRANSCRIPT)
(RUNTIME STRING-I/O-PORT)
(RUNTIME USER-INTERFACE)
- ;; These MUST be done before (RUNTIME PATHNAME)
+ ;; These MUST be done before (RUNTIME PATHNAME)
;; Typically only one of them is loaded.
(RUNTIME PATHNAME UNIX)
(RUNTIME PATHNAME DOS)
(define binhex40-header-regexp
"[\r\n\t ]*(This file must be converted with BinHex.*[\r\n][\r\n\t ]*:")
-(define (decode-binhex40-decoding context string start end)
+(define (decode-binhex40-decoding context string start end)
(let ((buffer (binhex40-decoding-context/input-buffer context)))
(let loop
((start start)
(define (make-<=-operator <)
(make-comparison-operator (lambda (x y) (not (< y x))) 'make-<=-operator))
-
+
(define (make->=-operator <)
(make-comparison-operator (lambda (x y) (not (< x y))) 'make->=-operator))
binary-invert-op))
-(define (make-arithmetic-package package-name . operations)
+(define (make-arithmetic-package package-name . operations)
(lambda (m . opt)
(cond ((eq? m 'bound-names) (map car operations))
((eq? m 'package-name) package-name)
(parse-digits string start end 0 exactness radix
(lambda (start* integer exactness sharp?)
sharp?
- (and (> start* start) ; >0 denominator digits
+ (and (> start* start) ; >0 denominator digits
(parse-complex string start* end
(finish integer exactness sign)
exactness radix sign))))))
(finish-real integer exponent exactness sign)
(parse-decimal-5 string start end
integer exponent exactness sign))))
-
-
+
(and (fix:< start end)
(let ((esign (string-ref string start)))
(if (sign? esign)
(apply-exactness exactness
(* (apply-sign sign integer)
(expt 10 exponent))))
-
+
(if (or (eq? 'INEXACT exactness) (eq? 'IMPLICIT-INEXACT exactness))
(let ((abs-exponent (if (< exponent 0) (- exponent) exponent))
(powers-of-10 exact-flonum-powers-of-10))
;; $MITSCHEME_LIBRARY_PATH/runtime/) into the environment of the
;; package named PACKAGE-NAME, and then evaluates EXPR in that load
;; environment. If EXPR is #F of course evaluating it has no effect.
-;;
+;;
;; (FURTHER-LOAD-OPTIONS EXPR)
;; EXPR is the place to look next for the load options. Useful objects
;; are STANDARD-LOAD-OPTIONS (load options supplied with the
(define-integrable ROP_DSTINVERT #x55)
(define-integrable ROP_ZERO #x00)
(define-integrable ROP_ONE #xFF)
-
+
;; Constants for OS2PS-BITBLT options argument
(define-integrable BBO_OR 0)
(define-integrable BBO_AND 1)
(string->symbol string)
(or (check-for-keyword string (db-keyword-style db))
(string->symbol string)))))
-
+\f
;; It'd be nice to have keyword objects work as part of the
;; parser-table, but not everyone does keywords the same way
;; (leading vs. trailing), so we'll just to check at the
(pq-tty 1)
(pq-unescape-bytea 1)
(pq-user 1))
-
+\f
(define-syntax define-enum
(sc-macro-transformer
(lambda (form environment)
(define (poll-pgsql-reset connection)
(index->name (pq-reset-poll (connection->handle connection))
postgres-polling-status))
-
+\f
(define-syntax define-connection-accessor
(sc-macro-transformer
(lambda (form environment)
(define (port/operation port name)
(guarantee-port port 'port/operation)
(port/%operation port name))
-
+\f
(define-syntax define-port-operation
(sc-macro-transformer
(lambda (form environment)
(len (vector-length new)))
((ucode-primitive declare-compiled-code-block 1) typed)
(add-association! obj typed)
- (do ((i (fix:+ (object-datum (vector-ref new 0)) 1) (fix:+ 1 i)))
+ (do ((i (fix:+ (object-datum (vector-ref new 0)) 1) (fix:+ 1 i)))
((not (fix:< i len)))
(vector-set! new i (copy-object (vector-ref new i))))
typed))
(define-integrable (atomically thunk)
- (with-absolutely-no-interrupts thunk))
+ (with-absolutely-no-interrupts thunk))
\f
(define ((%copy-pair type) obj)
(%%copy-pair type obj))
(define (copy-VARIABLE-object obj)
(let ((var (make-variable (variable-name obj))))
(add-association! obj var)
- var))
+ var))
(define (copy-COMMENT-object obj)
(let ((the-text (comment-text obj)))
(define (quick-sort! vector predicate)
(define (outer-loop l r)
(if (fix:> r l)
- (if (fix:= r (fix:+ l 1))
+ (if (fix:= r (fix:+ l 1))
(if (predicate (vector-ref vector r)
(vector-ref vector l))
(exchange! l r))
(if (fix:zero? n)
(make-compiled-regexp string case-fold?)
(let ((result
- (string-allocate
+ (string-allocate
(let ((qr (integer-divide n 255)))
(fix:+ (fix:* 257 (integer-divide-quotient qr))
(let ((r (integer-divide-remainder qr)))
(initialization (initialize-package!)))
(define-package (runtime primitive-io)
- (files "io")
+ (files "io")
(parent (runtime))
(export ()
all-dld-handles
rexp-line-end
rexp-line-start
rexp-n*
- rexp-n*m
+ rexp-n*m
rexp-n*n
rexp-not-syntax-char
rexp-not-word-char
(compiled-code-address->block (fasload filename)))
(define (compiled-code-block/manifest-closure? block)
- (object-type?
+ (object-type?
(ucode-type manifest-closure)
;; This combination returns an unsafe object, but since it
;; is used as an argument to a primitive, I can get away
(define (looks-like-keyword? string)
(case (environment-lookup *environment* '*KEYWORD-STYLE*)
- ((BOTH)
+ ((BOTH)
(or (char=? (string-ref string 0) #\:)
(char=? (string-ref string (- (string-length string) 1)) #\:)))
((CL)
(set-cdr! bound old)
value))
(action argument)))
-
+
(define (unsyntax scode)
(fluid-let ((bound (list #F '())))
(unsyntax-object (if (procedure? scode) (procedure-lambda scode) scode))))
unexpand-disjunction
(lambda (predicate alternative)
(list (unsyntax-object predicate)
- (unsyntax-object alternative)))))))
+ (unsyntax-object alternative)))))))
(define (unexpand-disjunction predicate alternative)
`(,(unsyntax-object predicate)
#f)))))
(else
(loop (entity-procedure p1))))
-
-
#f))))
\ No newline at end of file
(define (write-words words line-prefix indentation port)
(let ((wrap-column (- (output-port/x-size port) 5))
(space " "))
-
+
(define (write-first-word words indent?)
(write-string line-prefix port)
(if indent? (write-string indentation port))
(difference #F read-only true)
(subset? #F read-only true)
(rank #F read-only true)
-)
+)
\f
;;; Tree representation
;;;
(define (node/rank k node rank)
(cond ((empty? node) #f)
((key<? k (node/k node)) (node/rank k (node/l node) rank))
- ((key>? k (node/k node))
+ ((key>? k (node/k node))
(node/rank k (node/r node)
(fix:+ 1 (fix:+ rank (node/size (node/l node))))))
(else (fix:+ rank (node/size (node/l node))))))
((key<? (node/k node) x)
(node/split-gt (node/r node) x))
((key<? x (node/k node))
- (node/concat3 (node/k node) (node/v node)
+ (node/concat3 (node/k node) (node/v node)
(node/split-gt (node/l node) x) (node/r node)))
(else (node/r node))))
(cond ((null? alist) node)
((pair? alist) (loop (cdr alist)
(node/add node (caar alist) (cdar alist))))
- (else
+ (else
(error:wrong-type-argument alist "alist" 'alist->tree))))
(%make-wt-tree my-type (loop alist empty)))
))
my-type)
-
+
;;;
(let ((xw
(x-graphics-open-window
(x-display/xd display)
- (if (default-object? geometry)
+ (if (default-object? geometry)
x-graphics-default-geometry
geometry)
(vector #f resource class))))
(->flonum angle-start)
(->flonum angle-sweep)
fill?))
-
+
(define (x-graphics/draw-circle device x y radius)
(x-graphics-draw-arc (x-graphics-device/xw device)
(->flonum x)
0.
360.
#f))
-
+
(define (x-graphics/fill-circle device x y radius)
(x-graphics-draw-arc (x-graphics-device/xw device)
(->flonum x)
0.
360.
#t))
-
+
(define (x-graphics/fill-polygon device point-vector)
(x-graphics-fill-polygon (x-graphics-device/xw device)
(vector-map ->flonum point-vector)))
-
+
(define (x-graphics/copy-area device source-x-left source-y-top width height
destination-x-left destination-y-top)
(let ((xw (x-graphics-device/xw device)))
projects / mit-scheme.git / commitdiff