prescheme.scm 3.4 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139
  1. ; Copyright (c) 1993-2008 by Richard Kelsey and Jonathan Rees. See file COPYING.
  2. ; Stuff in Pre-Scheme that is not in Scheme.
  3. (define shift-left arithmetic-shift)
  4. (define (arithmetic-shift-right i n)
  5. (arithmetic-shift i (- 0 n)))
  6. ; Hack for the robots
  7. (define small* *) ; could do a range check
  8. (define int-mask (- (arithmetic-shift 1 pre-scheme-integer-size) 1))
  9. (define (logical-shift-right i n)
  10. (if (>= i 0)
  11. (arithmetic-shift i (- 0 n))
  12. (arithmetic-shift (bitwise-and i int-mask) (- 0 n))))
  13. (define (deallocate x) #f)
  14. (define the-null-pointer (list 'null-pointer))
  15. (define (null-pointer? x) (eq? x the-null-pointer))
  16. (define (null-pointer)
  17. the-null-pointer)
  18. (define-external-enumeration errors
  19. (no-errors
  20. (parse-error "EDOM")
  21. (file-not-found "ENOENT")
  22. (out-of-memory "ENOMEM")
  23. (invalid-port "EBADF")
  24. ))
  25. (define (error-string status)
  26. "an error")
  27. ; (symbol->string (enumerand->name status errors)))
  28. (define (open-input-file name)
  29. (let ((port (scheme:open-input-file name)))
  30. (values port
  31. (if port
  32. (enum errors no-errors)
  33. (enum errors file-not-found)))))
  34. (define (open-output-file name)
  35. (let ((port (scheme:open-output-file name)))
  36. (values port
  37. (if port
  38. (enum errors no-errors)
  39. (enum errors file-not-found)))))
  40. (define (close-input-port port)
  41. (scheme:close-input-port port)
  42. (enum errors no-errors))
  43. (define (close-output-port port)
  44. (scheme:close-output-port port)
  45. (enum errors no-errors))
  46. (define (read-char port)
  47. (let ((ch (scheme:read-char port)))
  48. (if (eof-object? ch)
  49. (values (ascii->char 0) #t (enum errors no-errors))
  50. (values ch #f (enum errors no-errors)))))
  51. (define (peek-char port)
  52. (let ((ch (scheme:peek-char port)))
  53. (if (eof-object? ch)
  54. (values (ascii->char 0) #t (enum errors no-errors))
  55. (values ch #f (enum errors no-errors)))))
  56. (define (read-integer port)
  57. (eat-whitespace! port)
  58. (let ((neg? (let ((x (scheme:peek-char port)))
  59. (if (eof-object? x)
  60. #f
  61. (case x
  62. ((#\+) (scheme:read-char port) #f)
  63. ((#\-) (scheme:read-char port) #t)
  64. (else #f))))))
  65. (let loop ((n 0) (any? #f))
  66. (let ((x (scheme:peek-char port)))
  67. (cond ((and (char? x)
  68. (char-numeric? x))
  69. (scheme:read-char port)
  70. (loop (+ (* n 10)
  71. (- (char->integer x)
  72. (char->integer #\0)))
  73. #t))
  74. (any?
  75. (values (if neg? (- n) n) #f (enum errors no-errors)))
  76. ((eof-object? x)
  77. (values 0 #t (enum errors no-errors)))
  78. (else
  79. (values 0 #f (enum errors parse-error))))))))
  80. (define (eat-whitespace! port)
  81. (cond ((char-whitespace? (scheme:peek-char port))
  82. (scheme:read-char port)
  83. (eat-whitespace! port))))
  84. (define (write-x string port)
  85. (display string port)
  86. (enum errors no-errors))
  87. (define write-char write-x)
  88. (define write-string write-x)
  89. (define write-integer write-x)
  90. (define (force-output port)
  91. (enum errors no-errors))
  92. (define (newline port)
  93. (write-char #\newline port)
  94. (enum errors no-errors))
  95. (define-syntax goto
  96. (lambda (exp rename compare)
  97. (cdr exp)))
  98. ; (external <string> <type> . <maybe scheme value>)
  99. (define-syntax external
  100. (lambda (exp rename compare)
  101. (if (null? (cdddr exp))
  102. exp
  103. (cadddr exp))))
  104. (define current-error-port current-output-port)
  105. ; RECEIVE (from big-scheme)
  106. (define-syntax receive
  107. (syntax-rules ()
  108. ((receive ?vars ?producer . ?body)
  109. (call-with-values (lambda () ?producer)
  110. (lambda ?vars . ?body)))))