From 61c27b403e327ee75e404a21ca130c7f4e7adfb2 Mon Sep 17 00:00:00 2001 From: ESL Date: Sat, 15 Jun 2024 14:29:16 -0400 Subject: [PATCH] listname->symbol, ltos fix --- i.c | 6 ++++-- src/t.scm | 31 +++++++++++++++++++++++++++++++ t.c | 12 ++++++++++++ 3 files changed, 47 insertions(+), 2 deletions(-) diff --git a/i.c b/i.c index 18ac7db..c949846 100644 --- a/i.c +++ b/i.c @@ -1597,8 +1597,10 @@ define_instruction(ltos) { obj l = ac; int n = 0, i, *d; while (is_pair(l)) { l = pair_cdr(l); ++n; } d = allocstring(n, ' '); - for (i = 0; i < n; ac = pair_cdr(ac), ++i) - sdatachars(d)[i] = get_char(pair_car(ac)); + for (i = 0; i < n; ac = pair_cdr(ac), ++i) { + obj x = pair_car(ac); ckc(x); + sdatachars(d)[i] = get_char(x); + } ac = string_obj(d); gonexti(); } diff --git a/src/t.scm b/src/t.scm index 48542e4..c5bb50f 100644 --- a/src/t.scm +++ b/src/t.scm @@ -1262,6 +1262,37 @@ ; Library names and library file lookup ;--------------------------------------------------------------------------------------------- +(define (listname->symbol lib) + (define postfix "/") + (define prefix "") + (define commons '(#\- #\< #\= #\>)) + (define symbol-prefix "/") + (define number-prefix ".") + (define (mangle-symbol sym) + (let loop ([lst (string->list (symbol->string sym))] [text '()]) + (cond [(null? lst) + (list->string (reverse text))] + [(or (char-alphabetic? (car lst)) (char-numeric? (car lst))) + (loop (cdr lst) (cons (car lst) text))] + [(memv (car lst) commons) + (loop (cdr lst) (cons (car lst) text))] + [else + (let* ([s (number->string (char->integer (car lst)) 16)] + [s (if (< (string-length s) 2) (string-append "0" s) s)] + [l (cons #\% (string->list (string-upcase s)))]) + (loop (cdr lst) (append (reverse l) text)))]))) + (define (mangle-number num) + (number->string num)) + (unless (list? lib) (x-error "invalid library name" lib)) + (let loop ([lst lib] [parts (list prefix)]) + (if (null? lst) + (string->symbol (apply string-append (reverse (cons postfix parts)))) + (cond [(symbol? (car lst)) + (loop (cdr lst) (cons (mangle-symbol (car lst)) (cons symbol-prefix parts)))] + [(exact-integer? (car lst)) + (loop (cdr lst) (cons (mangle-number (car lst)) (cons number-prefix parts)))] + [else (x-error "invalid library name" lib)])))) + (define (listname-segment->string s) (cond [(symbol? s) (symbol->string s)] [(number? s) (number->string s)] diff --git a/t.c b/t.c index a7775d7..685f04d 100644 --- a/t.c +++ b/t.c @@ -647,6 +647,18 @@ char *t_code[] = { "(y14:path-directory)[01},.2,@(y34:file-resolve-relative-to-base-path)[" "22}.1]2}.0]1", + "P", "listname->symbol", + "%1,,,,,,,#0#1#2#3#4#5#6'(s1:/).!0'(s0:).!1'(l4:c-;c<;c=;c>;).!2'(s1:/)" + ".!3'(s1:.).!4.2,&1{%1n,.1X4X2,,#0.0,:0,&2{%2.0u?{.1A8X3]2}.0aC4,.0?{.0" + "}{.1aC5}_1?{.1,.1ac,.1d,:1^[22}:0^,.1aA1?{.1,.1ac,.1d,:1^[22}'(i16),.1" + "aX8E8,'2,.1S3string", "%1.0Y0?{.0X4]1}.0N0?{'(i10),.1E8]1}.0S0?{.0]1}.0,'(s34:invalid symboli" "c file name element),@(y7:c-error)[12",