Prevent overwritting evn's when importing from repl

This commit is contained in:
Justin Ethier 2020-07-27 17:53:31 -04:00
parent 152a210619
commit b350a0cf33
4 changed files with 53 additions and 32 deletions

View file

@ -4,6 +4,7 @@
Features Features
- The compiler now provides improved error messages with file and line numbers for a wide range of syntax errors.
- Added `c-void` type into `(cyclone foreign)`. - Added `c-void` type into `(cyclone foreign)`.
Bug Fixes Bug Fixes

View file

@ -9,8 +9,6 @@
(define-library (scheme base) (define-library (scheme base)
(import (scheme cyclone common)) (import (scheme cyclone common))
(export (export
*source-loc-lis*
error/loc
member member
assoc assoc
cons-source cons-source
@ -132,6 +130,7 @@
error-object-irritants error-object-irritants
; TODO: file-error? ; TODO: file-error?
; TODO: read-error? ; TODO: read-error?
error/loc
error error
raise raise
raise-continuable raise-continuable
@ -234,33 +233,6 @@
fast-string=? fast-string=?
) )
(begin (begin
(define *source-loc-lis* '())
(define (error/loc reason expr . args)
;; Does reason already include line/file location info?
(define (reason/line-loc? reason)
(and (string? reason)
(equal? (substring reason 0 8)
"at line ")))
(let* ((found (assoc expr *source-loc-lis*))
(loc-vec (if found
(cdr found) ;; Get value
#f))
(msg (if (and loc-vec ;; Have line info
(not (reason/line-loc? reason))) ;; Not there yet
(string-append
"at line "
(number->string (vector-ref loc-vec 1))
", column "
(number->string (vector-ref loc-vec 2))
" of "
(vector-ref loc-vec 0)
": "
reason)
reason)))
(if (pair? args)
(apply error (cons msg args))
(error msg expr))))
;; Features implemented by this Scheme ;; Features implemented by this Scheme
(define (features) (define (features)
(cons (cons
@ -1310,6 +1282,41 @@
} }
return_closcall1(data, k, thd->exception_handler_stack); ") return_closcall1(data, k, thd->exception_handler_stack); ")
;; Non-standard, used internally by Cyclone to report line number
;; information for error messages
(define (error/loc reason expr . args)
;(Cyc-write `(error/loc ,(map
; (lambda (alis)
; (list (car alis)
; (memloc (car alis))
; (cdr alis)))
; *reader-source-db*)))
;(Cyc-display "\n")
;; Does reason already include line/file location info?
(define (reason/line-loc? reason)
(and (string? reason)
(equal? (substring reason 0 8)
"at line ")))
(let* ((found (assoc expr *reader-source-db*))
(loc-vec (if found
(cdr found) ;; Get value
#f))
(msg (if (and loc-vec ;; Have line info
(not (reason/line-loc? reason))) ;; Not there yet
(string-append
"at line "
(number->string (vector-ref loc-vec 1))
", column "
(number->string (vector-ref loc-vec 2))
" of "
(vector-ref loc-vec 0)
": "
reason)
reason)))
(if (pair? args)
(apply error (cons msg args))
(error msg expr))))
;; Simplified versions of every/any from SRFI-1 ;; Simplified versions of every/any from SRFI-1
(define (any pred lst) (define (any pred lst)
(let any* ((l (map pred lst))) (let any* ((l (map pred lst)))

View file

@ -13,7 +13,10 @@
*version-number* *version-number*
*version-name* *version-name*
*version-banner* *version-banner*
*c-file-header-comment*) *c-file-header-comment*
*reader-source-db*
memloc
)
(begin (begin
(define *version-number* "0.19") (define *version-number* "0.19")
(define *version-name* "") (define *version-name* "")
@ -52,4 +55,13 @@
**/ **/
")) "))
(define *reader-source-db* '())
(define-c memloc
"(void *data, int argc, closure _, object k, object obj)"
" char str[32];
sprintf(str, \"%p\", obj);
make_utf8_string(data, s, str);
return_closcall1(data, k, &s);")
)) ))

View file

@ -8,6 +8,7 @@
;;;; ;;;;
(define-library (scheme read) (define-library (scheme read)
(import (scheme base) (import (scheme base)
(scheme cyclone common)
;(scheme write) ;(scheme write)
(scheme char)) (scheme char))
(export (export
@ -173,9 +174,9 @@
return_closcall1(data, k, obj_int2obj(num)); ") return_closcall1(data, k, obj_int2obj(num)); ")
(define (store-source-info! obj filename line col) (define (store-source-info! obj filename line col)
(set! *source-loc-lis* (set! *reader-source-db*
(cons (cons obj (vector filename line col)) (cons (cons obj (vector filename line col))
*source-loc-lis*))) *reader-source-db*)))
;; TODO: where to store? Need to use a hashtable but also needs to ;; TODO: where to store? Need to use a hashtable but also needs to
;; be accessible from macro's. probably needs to be in global env, ;; be accessible from macro's. probably needs to be in global env,
;; see (cyclone foreign) for an example ;; see (cyclone foreign) for an example