trying to get records up....WIP
This commit is contained in:
Jan Nieuwenhuizen
parent
f61a6c2228
commit
5126e16e66
33
GNUmakefile
33
GNUmakefile
|
|
@ -33,16 +33,39 @@ mes.h: mes.c GNUmakefile
|
|||
check: all
|
||||
./mes.test
|
||||
./mes.test ./mes
|
||||
cat scm.mes test.mes | ./mes
|
||||
cat scm.mes lib/srfi/srfi-0.scm test.mes | ./mes
|
||||
|
||||
run: all
|
||||
cat scm.mes test.mes | ./mes
|
||||
|
||||
syntax: all
|
||||
cat scm.mes syntax.mes | ./mes
|
||||
psyntax: all
|
||||
cat scm.mes psyntax.mes psyntax.pp psyntax2.mes | ./mes
|
||||
|
||||
guile-syntax:
|
||||
guile -s syntax.mes
|
||||
syntax: all
|
||||
cat scm.mes syntax.mes syntax-test.mes | ./mes
|
||||
|
||||
syntax.test: syntax.mes syntax-test.mes
|
||||
cat $^ > $@
|
||||
|
||||
guile-syntax: syntax.test
|
||||
guile -s $^
|
||||
|
||||
macro: all
|
||||
cat scm.mes macro.mes | ./mes
|
||||
|
||||
peg: all
|
||||
cat scm.mes syntax.mes peg.mes peg/codegen.scm peg/string-peg.scm peg/simplify-tree.scm peg/using-parsers.scm peg/cache.scm peg-test.mes | ./mes
|
||||
|
||||
peg.test: peg/pmatch.scm peg.mes peg/codegen.scm peg/string-peg.scm peg/simplify-tree.scm peg/using-parsers.scm peg/cache.scm peg-test.mes
|
||||
cat $^ | sed 's,\(;; Packages the results of a parser\),(when (guile?) (set! compile-peg-pattern (@@ (ice-9 peg codegen) compile-peg-pattern)))\n\1,' > $@
|
||||
|
||||
guile-peg: peg.test
|
||||
# guile -s peg-test.mes
|
||||
# @echo "======================================="
|
||||
guile -s $^
|
||||
|
||||
clean:
|
||||
rm -f mes environment.i mes.h peg.test syntax.test
|
||||
|
||||
record: all
|
||||
cat scm.mes syntax.mes lib/record.mes lib/record.scm lib/srfi/srfi-9.scm record.mes |./mes
|
||||
|
|
|
|||
13
TODO
13
TODO
|
|
@ -19,6 +19,19 @@ See bugs/
|
|||
**** syntax-case
|
||||
** parse C using PEG
|
||||
http://piumarta.com/software/peg/
|
||||
** C grammar in lex/yacc
|
||||
https://github.com/rabishah/Mini-C-Compiler-using-Flex-And-Yacc
|
||||
https://www.lysator.liu.se/c/ANSI-C-grammar-y.html
|
||||
http://www2.cs.uidaho.edu/~jeffery/courses/nmsu/370/cgram.y
|
||||
https://github.com/ProgramLeague/C-Compilerp
|
||||
*** parsing in scheme
|
||||
ftp://ftp.cs.indiana.edu/pub/scheme-repository/code/lang/cgram-ll1
|
||||
** Tiny C
|
||||
https://en.wikipedia.org/wiki/Tiny_C_Compiler
|
||||
** Sub C
|
||||
http://www.t3x.org/subc/index.html
|
||||
**
|
||||
https://groups.google.com/forum/#!topic/comp.lang.lisp/VPuX0VsjTTE
|
||||
** implement core primitives: DONE
|
||||
begin
|
||||
define
|
||||
|
|
|
|||
257
lib/record.scm
257
lib/record.scm
|
|
@ -1,96 +1,203 @@
|
|||
; -*- Mode: Scheme; Syntax: Scheme; Package: Scheme; -*-
|
||||
; Copyright (c) 1993-2004 by Richard Kelsey and Jonathan Rees. See file COPYING.
|
||||
|
||||
|
||||
; This is file record.scm.
|
||||
|
||||
;;;; Records
|
||||
|
||||
; This is completely vanilla Scheme code. Should work anywhere.
|
||||
; Every record in the image is assumed to be made either by MAKE-RECORD-TYPE
|
||||
; or by a procedure returned by record-constructor. A record-type is a
|
||||
; record that describes a type of record. At the end of the file we create
|
||||
; a record type that describes record types.
|
||||
|
||||
(define (make-record-type type-id field-names)
|
||||
; We number the record types for debugging purposes.
|
||||
|
||||
(define unique (list type-id))
|
||||
(define *record-type-uid* -1)
|
||||
|
||||
(define size (+ (length field-names) 1))
|
||||
; This is the record type that describes record types. It is set a the end
|
||||
; of the file. Its first slot points to itself.
|
||||
|
||||
(define (constructor . names-option)
|
||||
(let* ((names (if (null? names-option)
|
||||
field-names
|
||||
(car names-option)))
|
||||
(number-of-inits (length names))
|
||||
(indexes (map field-index names)))
|
||||
(lambda field-values
|
||||
(if (= (length field-values) number-of-inits)
|
||||
(let ((record (make-vector size 'uninitialized)))
|
||||
(vector-set! record 0 unique)
|
||||
(for-each (lambda (index value)
|
||||
(vector-set! record index value))
|
||||
indexes
|
||||
field-values)
|
||||
record)
|
||||
(error "wrong number of arguments to record constructor"
|
||||
field-values type-id names)))))
|
||||
(define *record-type* #f)
|
||||
|
||||
(define (predicate obj)
|
||||
(and (vector? obj)
|
||||
(= (vector-length obj) size)
|
||||
(eq? (vector-ref obj 0) unique)))
|
||||
; Make a record type from a name, used for printing and debugging, and
|
||||
; a list of field names.
|
||||
;
|
||||
; The VM references both the record type and the resumer, so their offsets
|
||||
; should not be changed.
|
||||
|
||||
(define (accessor name)
|
||||
(let ((i (field-index name)))
|
||||
(lambda (record)
|
||||
(if (predicate record) ;Faster: (eq? (vector-ref record 0) unique)
|
||||
(vector-ref record i)
|
||||
(error "invalid argument to record accessor"
|
||||
record type-id name)))))
|
||||
(define (make-record-type name field-names)
|
||||
(set! *record-type-uid* (+ *record-type-uid* 1))
|
||||
(let ((r (make-record 7 (unspecific))))
|
||||
(record-set! r 0 *record-type*)
|
||||
(record-set! r 1 default-record-resumer)
|
||||
(record-set! r 2 *record-type-uid*)
|
||||
(record-set! r 3 name)
|
||||
(record-set! r 4 field-names)
|
||||
(record-set! r 5 (length field-names))
|
||||
(record-set! r 6 (make-default-record-discloser name))
|
||||
r))
|
||||
|
||||
(define (modifier name)
|
||||
(let ((i (field-index name)))
|
||||
(lambda (record new-value)
|
||||
(if (predicate record) ;Faster: (eq? (vector-ref record 0) unique)
|
||||
(vector-set! record i new-value)
|
||||
(error "invalid argument to record modifier"
|
||||
record type-id name)))))
|
||||
(define (record-type? obj)
|
||||
(and (record? obj)
|
||||
(eq? (record-type obj) *record-type*)))
|
||||
|
||||
(define (field-index name)
|
||||
(let loop ((l field-names) (i 1))
|
||||
(if (null? l)
|
||||
(error "bad field name" name)
|
||||
(if (eq? name (car l))
|
||||
i
|
||||
(loop (cdr l) (+ i 1))))))
|
||||
; The various fields in a record type.
|
||||
|
||||
(define the-descriptor
|
||||
(lambda (request)
|
||||
(case request
|
||||
((constructor) constructor)
|
||||
((predicate) predicate)
|
||||
((accessor) accessor)
|
||||
((modifier) modifier)
|
||||
((name) type-id)
|
||||
((field-names) field-names))))
|
||||
(define (record-type-resumer rt) (record-ref rt 1))
|
||||
(define (set-record-type-resumer! rt r) (record-set! rt 1 r))
|
||||
(define (record-type-uid rt) (record-ref rt 2))
|
||||
(define (record-type-name rt) (record-ref rt 3))
|
||||
(define (record-type-field-names rt) (record-ref rt 4))
|
||||
(define (record-type-number-of-fields rt) (record-ref rt 5))
|
||||
(define (record-type-discloser rt) (record-ref rt 6))
|
||||
(define (set-record-type-discloser! rt d) (record-set! rt 6 d))
|
||||
|
||||
the-descriptor)
|
||||
; This is a hack; it is read by the script that makes c/scheme48.h.
|
||||
|
||||
(define (record-constructor r-t . names-option)
|
||||
(apply (r-t 'constructor) names-option))
|
||||
(define record-type-fields
|
||||
'(resumer uid name field-names number-of-fields discloser))
|
||||
|
||||
(define (record-predicate r-t)
|
||||
(r-t 'predicate))
|
||||
;----------------
|
||||
; Given a record type and the name of a field, return the field's index.
|
||||
|
||||
(define (record-accessor r-t field-name)
|
||||
((r-t 'accessor) field-name))
|
||||
(define (record-field-index rt name)
|
||||
(let loop ((names (record-type-field-names rt))
|
||||
(i 1))
|
||||
(cond ((null? names)
|
||||
(error "unknown field"
|
||||
(record-type-name rt)
|
||||
name))
|
||||
((eq? name (car names))
|
||||
i)
|
||||
(else
|
||||
(loop (cdr names) (+ i 1))))))
|
||||
|
||||
(define (record-modifier r-t field-name)
|
||||
((r-t 'modifier) field-name))
|
||||
; Return procedure for contstruction records of type RT. NAMES is a list of
|
||||
; field names which the constructor will take as arguments. Other fields are
|
||||
; uninitialized.
|
||||
|
||||
(define (record-type-name r-t) (r-t 'name))
|
||||
(define (record-type-field-names r-t) (r-t 'field-names))
|
||||
(define (record-constructor rt names)
|
||||
(let ((indexes (map (lambda (name)
|
||||
(record-field-index rt name))
|
||||
names))
|
||||
(size (+ 1 (record-type-number-of-fields rt))))
|
||||
(lambda args
|
||||
(let ((r (make-record size (unspecific))))
|
||||
(record-set! r 0 rt)
|
||||
(let loop ((is indexes) (as args))
|
||||
(if (null? as)
|
||||
(if (null? is)
|
||||
r
|
||||
(error "too few arguments to record constructor"
|
||||
rt names args))
|
||||
(if (null? is)
|
||||
(error "too many arguments to record constructor"
|
||||
rt names args)
|
||||
(begin (record-set! r (car is) (car as))
|
||||
(loop (cdr is) (cdr as))))))))))
|
||||
|
||||
(define (record-type? r-t)
|
||||
(and (procedure? r-t)
|
||||
(error "record-type? not implemented" r-t)))
|
||||
; Making accessors, modifiers, and predicates for record types.
|
||||
|
||||
(define (record-accessor rt name)
|
||||
(let ((index (record-field-index rt name))
|
||||
(error-cruft `(record-accessor ,rt ',name)))
|
||||
(lambda (r)
|
||||
(if (eq? (record-type r) rt)
|
||||
(record-ref r index)
|
||||
(call-error "invalid record access" error-cruft r)))))
|
||||
|
||||
(define (record-modifier rt name)
|
||||
(let ((index (record-field-index rt name))
|
||||
(error-cruft `(record-modifier ,rt ',name)))
|
||||
(lambda (r x)
|
||||
(if (eq? (record-type r) rt)
|
||||
(record-set! r index x)
|
||||
(call-error "invalid record modification" error-cruft r x)))))
|
||||
|
||||
(define (record-predicate rt)
|
||||
(lambda (x)
|
||||
(and (record? x)
|
||||
(eq? (record-type x) rt))))
|
||||
|
||||
;----------------
|
||||
; A discloser is a procedure that takes a record of a particular type and
|
||||
; returns a list whose head is a string or symbol and whose tail is other
|
||||
; stuff.
|
||||
;
|
||||
; Set the discloser for record type RT.
|
||||
|
||||
(define (define-record-discloser rt proc)
|
||||
(if (and (record-type? rt)
|
||||
(procedure? proc))
|
||||
(set-record-type-discloser! rt proc)
|
||||
(call-error "invalid argument" define-record-discloser rt proc)))
|
||||
|
||||
; By default we just return the name of the record type.
|
||||
|
||||
(define (make-default-record-discloser record-type-name)
|
||||
(lambda (r)
|
||||
(list record-type-name)))
|
||||
|
||||
; DISCLOSE-RECORD calls the record's discloser procedure to obtain a list.
|
||||
|
||||
(define (disclose-record r)
|
||||
(if (record? r)
|
||||
(let ((rt (record-type r)))
|
||||
(if (record-type? rt)
|
||||
((record-type-discloser rt) r)
|
||||
#f))
|
||||
#f))
|
||||
|
||||
;----------------
|
||||
; A resumer is a procedure that the VM calls on all records of a given
|
||||
; type on startup.
|
||||
;
|
||||
; A resumer may be:
|
||||
; #t -> do nothing on startup.
|
||||
; #f -> records of this type do not survive a dump/resume; in images they
|
||||
; are replaced by their first slot (so we make sure they have one)
|
||||
; a one-argument procedure -> pass the record to this procedure
|
||||
;
|
||||
; Resumers are primarily intended for use by external code which keeps
|
||||
; fields in records which do not survive a dump under their own power.
|
||||
; For example, a record may contain a reference to a OS-dependent value.
|
||||
;
|
||||
; Resumers are called by the VM on startup.
|
||||
|
||||
(define (define-record-resumer rt resumer)
|
||||
(if (and (record-type? rt)
|
||||
(or (eq? #t resumer)
|
||||
(and (eq? #f resumer)
|
||||
(< 0 (record-type-number-of-fields rt)))
|
||||
(procedure? resumer)))
|
||||
(set-record-type-resumer! rt resumer)
|
||||
(call-error "invalid argument" define-record-resumer rt resumer)))
|
||||
|
||||
; By default we leave records alone.
|
||||
|
||||
(define default-record-resumer
|
||||
#t)
|
||||
|
||||
(define (initialize-records! resumer-records)
|
||||
(if (vector? resumer-records)
|
||||
(do ((i 0 (+ i 1)))
|
||||
((= i (vector-length resumer-records)))
|
||||
(resume-record (vector-ref resumer-records i)))))
|
||||
|
||||
(define (resume-record record)
|
||||
((record-type-resumer (record-type record))
|
||||
record))
|
||||
|
||||
;----------------
|
||||
; Initializing *RECORD-TYPE* and making a type.
|
||||
|
||||
(set! *record-type*
|
||||
(make-record-type 'record-type record-type-fields))
|
||||
|
||||
(record-set! *record-type* 0 *record-type*)
|
||||
|
||||
(define :record-type *record-type*)
|
||||
|
||||
(define-record-discloser :record-type
|
||||
(lambda (rt)
|
||||
(list 'record-type
|
||||
(record-type-uid rt)
|
||||
(record-type-name rt))))
|
||||
|
||||
(define (define-record-discloser r-t proc)
|
||||
"ignoring define-record-discloser form")
|
||||
|
|
|
|||
|
|
@ -1,160 +1,44 @@
|
|||
; Copyright (c) 1993-2004 by Richard Kelsey and Jonathan Rees. See file COPYING.
|
||||
;; Copyright (c) 1993 by Richard Kelsey and Jonathan Rees. See file COPYING.
|
||||
|
||||
;; There's no implicit name concatenation, so it can be defined
|
||||
;; entirely using syntax-rules. Example:
|
||||
;; (define-record-type foo type/foo
|
||||
;; (make-foo x y)
|
||||
;; foo? - predicate name is optional
|
||||
;; (x foo-x)
|
||||
;; (y foo-y)
|
||||
;; (z foo-z set-foo-z!))
|
||||
|
||||
; This knows about the implementation of records and creates the various
|
||||
; accessors, mutators, etc. directly instead of calling the procedures
|
||||
; from the record structure. This is done to allow the optional auto-inlining
|
||||
; optimizer to inline the accessors, mutators, etc.
|
||||
|
||||
; LOOPHOLE is used to get a little compile-time type checking (in addition to
|
||||
; the usual complete run-time checking).
|
||||
;; Copyright (c) 1993-2004 by Richard Kelsey and Jonathan Rees. See file COPYING.
|
||||
|
||||
(define-syntax define-record-type
|
||||
(syntax-rules ()
|
||||
((define-record-type ?id ?type
|
||||
(?constructor ?arg ...)
|
||||
(?field . ?field-stuff)
|
||||
((define-record-type id type
|
||||
(constructor arg ...)
|
||||
(field . field-stuff)
|
||||
...)
|
||||
(begin (define ?type (make-record-type '?id '(?field ...)))
|
||||
(define-constructor ?constructor ?type
|
||||
((?arg :value) ...)
|
||||
(?field ...))
|
||||
(define-accessors ?type () (?field . ?field-stuff) ...)))
|
||||
((define-record-type ?id ?type
|
||||
(?constructor ?arg ...)
|
||||
?pred
|
||||
?more ...)
|
||||
(begin (define-record-type ?id ?type
|
||||
(?constructor ?arg ...)
|
||||
?more ...)
|
||||
(define ?pred
|
||||
(lambda (x)
|
||||
(and (record? x)
|
||||
(eq? ?type (record-ref x 0)))))))))
|
||||
|
||||
(define-syntax define-synchronized-record-type
|
||||
(syntax-rules ()
|
||||
((define-synchronized-record-type ?id ?type
|
||||
(?constructor ?arg ...)
|
||||
?pred
|
||||
(?field . ?field-stuff)
|
||||
...)
|
||||
(define-synchronized-record-type ?id ?type
|
||||
(?constructor ?arg ...)
|
||||
(?field ...)
|
||||
?pred
|
||||
(?field . ?field-stuff)
|
||||
...))
|
||||
((define-synchronized-record-type ?id ?type
|
||||
(?constructor ?arg ...)
|
||||
(?sync-field ...)
|
||||
?pred
|
||||
(?field . ?field-stuff)
|
||||
...)
|
||||
(begin (define ?type (make-record-type '?id '(?field ...)))
|
||||
(define-constructor ?constructor ?type
|
||||
((?arg :value) ...)
|
||||
(?field ...))
|
||||
(define ?pred
|
||||
(lambda (x)
|
||||
(and (record? x)
|
||||
(eq? ?type (record-ref x 0)))))
|
||||
(define-accessors ?type (?sync-field ...)
|
||||
(?field . ?field-stuff) ...)))))
|
||||
|
||||
; (define-constructor <id> <type> ((<arg> <arg-type>)*) (<field-name>*))
|
||||
;
|
||||
; Checks to see that there is an <arg> corresponding to every <field-name>.
|
||||
|
||||
(define-syntax define-constructor
|
||||
(lambda (e r c)
|
||||
(let ((%record (r 'record))
|
||||
(%begin (r 'begin))
|
||||
(%lambda (r 'lambda))
|
||||
(%loophole (r 'loophole))
|
||||
(%proc (r 'proc))
|
||||
(%unspecific (r 'unspecific))
|
||||
(name (cadr e))
|
||||
(type (caddr e))
|
||||
(args (map r (map car (cadddr e))))
|
||||
(arg-types (map cadr (cadddr e)))
|
||||
(fields (map r (caddr (cddr e)))))
|
||||
(define (mem? name list)
|
||||
(cond ((null? list) #f)
|
||||
((c name (car list)) #t)
|
||||
(else
|
||||
(mem? name (cdr list)))))
|
||||
(define (every? pred list)
|
||||
(cond ((null? list) #t)
|
||||
((pred (car list))
|
||||
(every? pred (cdr list)))
|
||||
(else #f)))
|
||||
(if (every? (lambda (arg)
|
||||
(mem? arg fields))
|
||||
args)
|
||||
`(define ,name
|
||||
(,%loophole (,%proc ,arg-types ,type)
|
||||
(,%lambda ,args
|
||||
(,%record ,type . ,(map (lambda (field)
|
||||
(if (mem? field args)
|
||||
field
|
||||
(list %unspecific)))
|
||||
fields)))))
|
||||
e)))
|
||||
(record begin lambda loophole proc unspecific))
|
||||
(begin (define type (make-record-type 'id '(field ...)))
|
||||
(define constructor (record-constructor type '(arg ...)))
|
||||
(define-accessors type (field . field-stuff) ...)))
|
||||
((define-record-type id type
|
||||
(constructor arg ...)
|
||||
pred
|
||||
more ...)
|
||||
(begin (define-record-type id type
|
||||
(constructor arg ...)
|
||||
more ...)
|
||||
(define pred (record-predicate type))))))
|
||||
|
||||
;; Straightforward version
|
||||
(define-syntax define-accessors
|
||||
(lambda (e r c)
|
||||
(let ((%define-accessor (r 'define-accessor))
|
||||
(%begin (r 'begin))
|
||||
(type (cadr e))
|
||||
(sync-fields (caddr e))
|
||||
(field-specs (cdddr e)))
|
||||
(define (mem? name list)
|
||||
(cond ((null? list) #f)
|
||||
((c name (car list)) #t)
|
||||
(else
|
||||
(mem? name (cdr list)))))
|
||||
(do ((i 1 (+ i 1))
|
||||
(field-specs field-specs (cdr field-specs))
|
||||
(ds '()
|
||||
(cons `(,%define-accessor
|
||||
,(mem? (caar field-specs)
|
||||
sync-fields)
|
||||
,type ,i ,@(cdar field-specs))
|
||||
ds)))
|
||||
((null? field-specs)
|
||||
`(,%begin ,@ds)))))
|
||||
(define-accessor begin))
|
||||
(syntax-rules ()
|
||||
((define-accessors type field-spec ...)
|
||||
(begin (define-accessor type . field-spec) ...))))
|
||||
|
||||
(define-syntax define-accessor
|
||||
(syntax-rules ()
|
||||
((define-accessor ?sync? ?type ?index ?accessor)
|
||||
(define ?accessor
|
||||
(loophole (proc (?type) :value)
|
||||
(lambda (r)
|
||||
((ref-proc ?sync?) (loophole :record r) ?type ?index)))))
|
||||
((define-accessor ?sync? ?type ?index ?accessor ?modifier)
|
||||
(begin (define-accessor ?sync? ?type ?index ?accessor)
|
||||
(define ?modifier
|
||||
(loophole (proc (?type :value) :unspecific)
|
||||
(lambda (r new)
|
||||
((set-proc ?sync?)
|
||||
(loophole :record r) ?type ?index new))))))
|
||||
((define-accessor ?sync? ?type ?index)
|
||||
(begin))))
|
||||
|
||||
(define-syntax ref-proc
|
||||
(syntax-rules ()
|
||||
((ref-proc #t)
|
||||
provisional-checked-record-ref)
|
||||
((ref-proc #f)
|
||||
checked-record-ref)))
|
||||
|
||||
(define-syntax set-proc
|
||||
(syntax-rules ()
|
||||
((set-proc #t)
|
||||
provisional-checked-record-set!)
|
||||
((set-proc #f)
|
||||
checked-record-set!)))
|
||||
|
||||
((define-accessor type field accessor)
|
||||
(define accessor (record-accessor type 'field)))
|
||||
((define-accessor type field accessor modifier)
|
||||
(begin (define accessor (record-accessor type 'field))
|
||||
(define modifier (record-modifier type 'field))))))
|
||||
|
|
|
|||
31
mes.c
31
mes.c
|
|
@ -342,6 +342,17 @@ eval (scm *e, scm *a)
|
|||
scm *entry = assq (name, a);
|
||||
scm *x = cdar (defines);
|
||||
set_cdr_x (entry, cdr (define (x, a)));
|
||||
if (eq_p (car (x), &symbol_define_macro) == &scm_t)
|
||||
// HACK: macros are global
|
||||
// should we go back to (*macro* . ...) entry?
|
||||
// scm *last = last_pair (a);
|
||||
// printf ("\n LAST=");
|
||||
// display (last);
|
||||
// puts ("");
|
||||
set_cdr_x (last_pair (a), cons (cons (name, cdr (define (x, a))), &scm_nil));
|
||||
// printf ("a=");
|
||||
// display (a);
|
||||
// puts ("");
|
||||
defines = cdr (defines);
|
||||
}
|
||||
scm *fubar = cons (&scm_dot, &scm_dot);
|
||||
|
|
@ -361,6 +372,8 @@ eval (scm *e, scm *a)
|
|||
return eval_quasiquote (cadr (e), add_unquoters (a));
|
||||
if (car (e) == &symbol_cond)
|
||||
return evcon (cdr (e), a);
|
||||
if (eq_p (car (e), &symbol_define) == &scm_t)
|
||||
return define (e, a);
|
||||
if (eq_p (car (e), &symbol_define_macro) == &scm_t)
|
||||
return define (e, a);
|
||||
if ((macro = lookup_macro (car (e), a)) != &scm_f)
|
||||
|
|
@ -606,6 +619,16 @@ length (scm *x)
|
|||
return make_number (n);
|
||||
}
|
||||
|
||||
scm *
|
||||
last_pair (scm *x)
|
||||
{
|
||||
//if (x != &scm_nil && cdr (x) != &scm_nil)
|
||||
//return last_pair (cdr (x));
|
||||
while (x != &scm_nil && cdr (x) != &scm_nil)
|
||||
x = cdr (x);
|
||||
return x;
|
||||
}
|
||||
|
||||
scm *
|
||||
builtin_list (scm *x/*...*/)
|
||||
{
|
||||
|
|
@ -833,9 +856,9 @@ display_helper (scm *x, bool cont, char *sep, bool quote)
|
|||
if (!cont) printf (")");
|
||||
}
|
||||
else if (x->type == VECTOR) {
|
||||
printf ("#(");
|
||||
for (int i = 0; i < x->length; i++)
|
||||
display_helper (x->vector[i], true, i ? " " : "", false);
|
||||
printf ("#[%d](", x->length);
|
||||
// for (int i = 0; i < x->length; i++)
|
||||
// display_helper (x->vector[i], true, i ? " " : "", false);
|
||||
printf (")");
|
||||
}
|
||||
else if (atom_p (x) == &scm_t) printf ("%s", x->name);
|
||||
|
|
@ -1112,6 +1135,8 @@ mes_environment ()
|
|||
a = cons (cons (&scm_nil, &scm_nil), a);
|
||||
a = cons (cons (&scm_t, &scm_t), a);
|
||||
a = cons (cons (&scm_unspecified, &scm_unspecified), a);
|
||||
a = cons (cons (&symbol_begin, &symbol_begin), a);
|
||||
a = cons (cons (&symbol_quote, &scm_quote), a);
|
||||
|
||||
#include "environment.i"
|
||||
|
||||
|
|
|
|||
8
scm.mes
8
scm.mes
|
|
@ -94,6 +94,11 @@
|
|||
(#t (eq? a b))))
|
||||
|
||||
(define (vector . rest) (list->vector rest))
|
||||
(define (make-vector n . x)
|
||||
(let ((fill (if (pair? x) (cdr x) *unspecified*)))
|
||||
(list->vector (let loop ((n n))
|
||||
(if (= 0 n) '()
|
||||
(cons fill (loop (- n 1))))))))
|
||||
|
||||
(define (apply f args)
|
||||
(eval (cons f args) (current-module)))
|
||||
|
|
@ -204,3 +209,6 @@
|
|||
(let loop ((lst lst))
|
||||
(if (or (null? lst) (null? (cdr lst))) lst
|
||||
(loop (cdr lst)))))
|
||||
|
||||
(define else #t)
|
||||
(define (unspecific) (if #f #f))
|
||||
|
|
|
|||
|
|
@ -4,7 +4,7 @@
|
|||
(display "syntax-error:")
|
||||
(display message)
|
||||
(display ":")
|
||||
;;(display thing)
|
||||
(display thing)
|
||||
(newline))
|
||||
|
||||
;;; Adapted from scheme48-1.1/scheme/alt/syntax.scm
|
||||
|
|
@ -246,5 +246,3 @@
|
|||
`(define-syntax ,(car id-pattern)
|
||||
(syntax-rules ()
|
||||
((,(car id-pattern) . ,(cdr id-pattern)) ,@template))))
|
||||
|
||||
(define else #t)
|
||||
|
|
|
|||
Loading…
Reference in New Issue