mirror of
https://github.com/justinethier/cyclone.git
synced 2025-05-23 20:15:05 +02:00
334787b6d6
Previously #f was returned in this case but it is more correct to raise an error instead. This prevents weird edge cases and is more consistent with other schemes.
326 lines
12 KiB
Scheme
326 lines
12 KiB
Scheme
;;;; Cyclone Scheme
|
|
;;;; https://github.com/justinethier/cyclone
|
|
;;;;
|
|
;;;; Copyright (c) 2014-2016, Justin Ethier
|
|
;;;; All rights reserved.
|
|
;;;;
|
|
;;;; This module contains the s-expression parser and supporting functions.
|
|
;;;;
|
|
(define-library (scheme read)
|
|
(import (scheme base)
|
|
(scheme cyclone common)
|
|
(scheme cyclone util)
|
|
;(scheme write)
|
|
(scheme char))
|
|
(export
|
|
read
|
|
read-all
|
|
read-all/source
|
|
include
|
|
include-ci)
|
|
(inline
|
|
Cyc-opaque-eq?
|
|
Cyc-opaque-unsafe-eq?
|
|
Cyc-opaque-unsafe-string?
|
|
Cyc-opaque-unsafe-string->number)
|
|
(begin
|
|
|
|
(define *sym-dot* (string->symbol "."))
|
|
(define *sym-unquote-splicing* (string->symbol ",@"))
|
|
(define *sym-datum-comment* (string->symbol "#;"))
|
|
|
|
(define-syntax include
|
|
(er-macro-transformer
|
|
(lambda (expr rename compare)
|
|
|
|
(define (dirname filename)
|
|
(let loop ((index (string-length filename)))
|
|
(if (zero? index)
|
|
""
|
|
(let ((index (- index 1)))
|
|
(if (char=? (string-ref filename index) #\/)
|
|
(substring filename 0 index)
|
|
(loop index))))))
|
|
|
|
(define (massage filename)
|
|
(cond
|
|
;; may happen in the REPL
|
|
((not (current-expand-filepath)) filename)
|
|
;; absolute filename
|
|
((char=? (string-ref filename 0) #\/) filename)
|
|
;; otherwise, open the file relative to the library that is
|
|
;; expanded
|
|
(else (let ((target (string-append (dirname (current-expand-filepath)) "/" filename)))
|
|
;; if the target exists use, otherwise fallback to the
|
|
;; backward compatible behavior.
|
|
(if (file-exists? target)
|
|
target
|
|
filename)))))
|
|
|
|
`(begin
|
|
,@(let ((filename (massage (cadr expr))))
|
|
(call-with-port
|
|
(open-input-file filename)
|
|
(lambda (port)
|
|
(read-all/source port filename))))))))
|
|
|
|
(define-syntax include-ci
|
|
(er-macro-transformer
|
|
(lambda (expr rename compare)
|
|
`(include ,@(cdr expr)))))
|
|
|
|
;; Convert a list read by the reader into an improper list
|
|
(define (->dotted-list lst)
|
|
(cond
|
|
((null? lst) '())
|
|
((equal? (car lst) *sym-dot*)
|
|
(cadr lst))
|
|
(else
|
|
(cons (car lst) (->dotted-list (cdr lst))))))
|
|
|
|
;; Main lexer/parser
|
|
(define read
|
|
(lambda args
|
|
(let ((fp (if (null? args)
|
|
(current-input-port)
|
|
(car args)))
|
|
(ssi! (if (and (pair? args)
|
|
(pair? (cdr args)))
|
|
(cadr args)
|
|
#f)) ;; Default
|
|
(fname (if (and (pair? args)
|
|
(pair? (cdr args))
|
|
(pair? (cddr args)))
|
|
(caddr args)
|
|
#f)))
|
|
(let ((result (parse fp ssi! fname)))
|
|
(if (Cyc-opaque? result)
|
|
(read-error fp fname "unexpected closing parenthesis")
|
|
result)))))
|
|
|
|
;; Read given file, collecting source location information so we
|
|
;; can give meaningful compiler error messages
|
|
(define (read-all/source port filename)
|
|
(read-all port store-source-info! filename))
|
|
|
|
;; read-all -> port -> [objects]
|
|
(define (read-all . args)
|
|
(let* ((fp (if (null? args)
|
|
(current-input-port)
|
|
(car args)))
|
|
(ssi! (if (and (pair? args)
|
|
(pair? (cdr args)))
|
|
(cadr args)
|
|
#f)) ;; Default
|
|
(fname (if (and ssi!
|
|
(pair? (cddr args)))
|
|
(caddr args)
|
|
#f)))
|
|
(define (loop fp result)
|
|
(let ((obj (read fp ssi! fname)))
|
|
(if (eof-object? obj)
|
|
(reverse result)
|
|
(loop fp (cons obj result)))))
|
|
(loop fp '())))
|
|
|
|
;;(define-c reading-from-file?
|
|
;; "(void *data, int argc, closure _, object k, object port)"
|
|
;; " object result = boolean_f;
|
|
;; Cyc_check_port(data, port);
|
|
;; if (((port_type *)port)->flags == 1) {
|
|
;; result = boolean_t;
|
|
;; }
|
|
;; return_closcall1(data, k, result);")
|
|
|
|
(define-c read-token
|
|
"(void *data, int argc, closure _, object k, object port)"
|
|
" Cyc_io_read_token(data, k, port);")
|
|
|
|
(define-c read-error
|
|
"(void *data, object _, int argc, object *args)"
|
|
" object port = args[1];
|
|
object filename = args[2];
|
|
object msg = args[3];
|
|
char buf[1024];
|
|
port_type *p;
|
|
Cyc_check_port(data, port);
|
|
Cyc_check_str(data, msg);
|
|
p = ((port_type *)port);
|
|
if (Cyc_is_string(filename) == boolean_t) {
|
|
snprintf(buf, 1023, \"at line %d, column %d of %s: %s\",
|
|
p->line_num, p->col_num,
|
|
string_str(filename),
|
|
string_str(msg));
|
|
} else {
|
|
snprintf(buf, 1023, \"at line %d, column %d: %s\",
|
|
p->line_num, p->col_num, string_str(msg));
|
|
}
|
|
Cyc_rt_raise_msg(data, buf);")
|
|
|
|
(define-c Cyc-opaque-eq?
|
|
"(void *data, int argc, closure _, object k, object opq, object obj)"
|
|
" if (Cyc_is_opaque(opq) == boolean_f)
|
|
return_closcall1(data, k, boolean_f);
|
|
return_closcall1(data, k, equalp( opaque_ptr(opq), obj ));"
|
|
"(void *data, object ptr, object opq, object obj)"
|
|
" if (Cyc_is_opaque(opq) == boolean_f)
|
|
return(boolean_f);
|
|
return(equalp( opaque_ptr(opq), obj ));")
|
|
|
|
(define-c Cyc-opaque-unsafe-eq?
|
|
"(void *data, int argc, closure _, object k, object opq, object obj)"
|
|
" return_closcall1(data, k, equalp( opaque_ptr(opq), obj ));"
|
|
"(void *data, object ptr, object opq, object obj)"
|
|
" return(equalp( opaque_ptr(opq), obj ));")
|
|
|
|
(define-c Cyc-opaque-unsafe-string?
|
|
"(void *data, int argc, closure _, object k, object opq)"
|
|
" return_closcall1(data, k, Cyc_is_string(opaque_ptr(opq)));"
|
|
"(void *data, object ptr, object opq)"
|
|
" return(Cyc_is_string(opaque_ptr(opq)));")
|
|
|
|
(define-c Cyc-opaque->string
|
|
"(void *data, int argc, closure _, object k, object opq)"
|
|
" return_closcall1(data, k, opaque_ptr(opq));"
|
|
"(void *data, object ptr, object opq)"
|
|
" return(opaque_ptr(opq));")
|
|
|
|
(define-c Cyc-opaque-unsafe-string->number
|
|
"(void *data, int argc, closure _, object k, object opq)"
|
|
" Cyc_string2number_(data, k, opaque_ptr(opq));")
|
|
|
|
(define-c Cyc-make-rect
|
|
"(void *data, int argc, closure _, object k, object r, object i)"
|
|
" Cyc_make_rectangular(data, k, r, i); ")
|
|
|
|
(define-c get-line-num
|
|
"(void *data, int argc, closure _, object k, object port)"
|
|
" int num = ((port_type *)port)->line_num;
|
|
return_closcall1(data, k, obj_int2obj(num)); ")
|
|
|
|
(define-c get-col-num
|
|
"(void *data, int argc, closure _, object k, object port)"
|
|
" int num = ((port_type *)port)->col_num;
|
|
return_closcall1(data, k, obj_int2obj(num)); ")
|
|
|
|
(define (store-source-info! obj filename line col)
|
|
(set! *reader-source-db*
|
|
(cons (cons obj (vector filename line col))
|
|
*reader-source-db*)))
|
|
;; 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,
|
|
;; see (cyclone foreign) for an example
|
|
;; TODO: need corresponding macro (syntax-error/source ??) to use this
|
|
;; information for error reporting
|
|
;; TODO: probably want to have a top-level exception handler on macro
|
|
;; expansion and call compiler error to report any error along with
|
|
;; source info
|
|
|
|
|
|
;; Parse given input port and retrieve next token
|
|
;;
|
|
;; Params:
|
|
;; fp - Input port
|
|
;; ssi! - "Store Source Info" function, or #f if none
|
|
;; fname - Filename being read, or #f if N/A
|
|
;;
|
|
;; Returns read token
|
|
(define (parse fp ssi! fname)
|
|
(let ((token (read-token fp)))
|
|
;;(display "//")(write `(token ,token)) (newline)
|
|
(cond
|
|
((Cyc-opaque? token)
|
|
(cond
|
|
((Cyc-opaque-unsafe-string? token)
|
|
(let ((rv (Cyc-opaque-unsafe-string->number token)))
|
|
(if rv
|
|
rv
|
|
(error "Invalid numeric syntax" (Cyc-opaque->string token)))))
|
|
;; Open paren, start read loop
|
|
((Cyc-opaque-unsafe-eq? token #\()
|
|
(let ((line-num (get-line-num fp))
|
|
(col-num (get-col-num fp)))
|
|
(let loop ((lis '())
|
|
(t (parse fp ssi! fname)))
|
|
(cond
|
|
((eof-object? t)
|
|
(read-error fp fname "missing closing parenthesis"))
|
|
((Cyc-opaque-eq? t #\))
|
|
(if (and (> (length lis) 2)
|
|
(equal? (cadr lis) *sym-dot*))
|
|
(->dotted-list (reverse lis))
|
|
(let ((result (reverse lis)))
|
|
(when (and ssi!
|
|
(pair? result)
|
|
(symbol? (car result)))
|
|
;; Possible macro expansion, save source info
|
|
(ssi! result
|
|
fname
|
|
line-num
|
|
(- col-num 1))) ;; Account for open paren
|
|
result)))
|
|
(else
|
|
(loop (cons t lis) (parse fp ssi! fname)))))))
|
|
((Cyc-opaque-unsafe-eq? token #\')
|
|
(list 'quote (parse fp ssi! fname)))
|
|
((Cyc-opaque-unsafe-eq? token #\`)
|
|
(list 'quasiquote (parse fp ssi! fname)))
|
|
((Cyc-opaque-unsafe-eq? token #\,)
|
|
(list 'unquote (parse fp ssi! fname)))
|
|
(else
|
|
token))) ;; error if this is returned to original caller of parse
|
|
((vector? token)
|
|
(cond
|
|
((= (vector-length token) 3) ;; Special case: exact/inexact number
|
|
(if (vector-ref token 2)
|
|
(exact (string->number (vector-ref token 0) (vector-ref token 1)))
|
|
(inexact (string->number (vector-ref token 0) (vector-ref token 1)))))
|
|
((= (vector-length token) 2) ;; Special case: special symbols
|
|
(let ((t (vector-ref token 0)))
|
|
(cond
|
|
((eq? t *sym-unquote-splicing*)
|
|
(list 'unquote-splicing (parse fp ssi! fname)))
|
|
((eq? t *sym-datum-comment*)
|
|
(parse fp ssi! fname) ;; Ignore next datum
|
|
(parse fp ssi! fname))
|
|
((string? t) ;; Special case: complex number
|
|
(let* ((end (vector-ref token 1))
|
|
(len (string-length t))
|
|
(only-imag? (= (+ 1 end) len)) ;; EG: "57i" with no real component
|
|
(real-str (if only-imag?
|
|
"0"
|
|
(substring t 0 end)))
|
|
(imag-str (if only-imag?
|
|
(substring t 0 end)
|
|
(substring t end (- len 1))))
|
|
(real (string->number real-str))
|
|
(imag (string->number imag-str))
|
|
)
|
|
(Cyc-make-rect real imag)))
|
|
(else
|
|
(error "Unexpected token" t)))))
|
|
((= (vector-length token) 1) ;; Special case: error
|
|
(error (vector-ref token 0)))
|
|
(else
|
|
(let loop ((lis '())
|
|
(t (parse fp ssi! fname)))
|
|
(cond
|
|
((eof-object? t)
|
|
(read-error fp fname "missing closing parenthesis"))
|
|
((Cyc-opaque-eq? t #\))
|
|
(list->vector (reverse lis)))
|
|
(else
|
|
(loop (cons t lis) (parse fp ssi! fname))))))))
|
|
((bytevector? token)
|
|
(let loop ((lis '())
|
|
(t (parse fp ssi! fname)))
|
|
(cond
|
|
((eof-object? t)
|
|
(read-error fp fname "missing closing parenthesis"))
|
|
((Cyc-opaque-eq? t #\))
|
|
(apply bytevector (reverse lis)))
|
|
(else
|
|
(loop (cons t lis) (parse fp ssi! fname))))))
|
|
(else
|
|
token))))
|
|
))
|