<commit_before>;;
;; Cyclone Scheme
;; Copyright (c) 2014, <NAME>
;; All rights reserved.
;;
;; This module compiles scheme code to a Cheney-on-the-MTA C runtime.
;;

(define (emit line)
  (display line)
  (newline))

(define (emits str)
  (display str))

(define (emit-newline)
  (newline))

(define (string-join lst delim)
  (cond
    ((null? lst) 
      "")
    ((= (length lst) 1) 
      (car lst))
    (else
      (string-append 
        (car lst) 
        delim 
        (string-join (cdr lst) delim)))))

;; Escape chars in a C-string, so it can be safely written to a C file
(define (cstr:escape-chars str)
  (letrec ((next (lambda (head tail)
                   (cond
                     ((null? head) (list->string (reverse tail)))
                     ((equal? (car head) #\")
                      (next (cdr head) (cons #\" (cons #\\ tail))))
                     ((equal? (car head) #\\)
                      (next (cdr head) (cons #\\ (cons #\\ tail))))
                     ((equal? (car head) #\newline)
                      (next (cdr head) 
                            (cons #\n (cons #\\ tail))))
                     (else
                       (next (cdr head) (cons (car head) tail)))))))
    (next (string->list str) '())))

;; Name-mangling.

;; We have to "mangle" Scheme identifiers into
;; C-compatible identifiers, because names like
;; foo-bar/baz are not identifiers in C.

; mangle : symbol -> string
(define (mangle symbol)
 (letrec
   ((m (lambda (chars)
      (if (null? chars)
        '()
        (if (or (and (char-alphabetic? (car chars)) (not (char=? (car chars) #\_)))
                (char-numeric? (car chars)))
            (cons (car chars) (m (cdr chars)))
            (cons #\_ (append (integer->char-list (char->natural (car chars)))
                              (m (cdr chars))))))))
    (ident (list->string (m (string->list (symbol->string symbol))))))
   (if (member (string->symbol ident) *c-keywords*)
     (string-append "_" ident)
     ident)))

(define (mangle-global symbol)
  (string-append "__glo_" (mangle symbol)))

(define *c-keywords* 
 '(auto _Bool break case char _Complex const continue default do double else
   enum extern float for goto if _Imaginary inline int long register restrict
   return short signed sizeof static struct switch typedef union unsigned
   void volatile while
   list  ;; Not a keyword but reserved type
   ))

(define *c-main-function*
"main(int argc,char **argv)
{long stack_size = long_arg(argc,argv,\"-s\",STACK_SIZE);
 long heap_size = long_arg(argc,argv,\"-h\",HEAP_SIZE);
 global_stack_size = stack_size;
 global_heap_size = heap_size;
 main_main(stack_size,heap_size,(char *) &stack_size);
 return 0;}")

;;; Auto-generation of C macros
(define *c-call-arity* 5)

(define (set-c-call-arity! arity)
  (cond
    ((not (number? arity))
     (error `(Non-numeric number of arguments received ,arity)))
    (else
      (if (> arity *c-call-arity*)
          (set! *c-call-arity* arity)))))

(define (emit-c-macros)
  (c-macro-declare-globals)
  (c-macro-GC-globals)
  (emit (c-macro-after-longjmp))
  (emit-c-arity-macros 0))

(define (emit-c-arity-macros arity)
  (when (<= arity *c-call-arity*)
    (emit (c-macro-funcall arity))
    (emit (c-macro-return-funcall arity))
    (emit (c-macro-return-check arity))
    (emit-c-arity-macros (+ arity 1))))

(define (c-macro-after-longjmp)
  (letrec (
    (append-args
      (lambda (n)
        (if (> n 0)
          (string-append
            (append-args (- n 1))
            ",gc_ans[" (number->string (- n 1)) "]")
          "")))
    (append-next-clause
      (lambda (i)
         (cond 
           ((= i 0)
            (string-append
              "  if (gc_num_ans == 0) { \\\n"
              "    funcall0((closure) gc_cont); \\\n"
              (append-next-clause (+ i 1))))
           ((<= i *c-call-arity*)
            (let ((this-clause
                    (string-append
                      "  } else if (gc_num_ans == " (number->string i)") { \\\n"
                      "    funcall" (number->string i) "((closure) gc_cont" (append-args i) "); \\\n")))
               (string-append 
                  this-clause
                  (append-next-clause (+ i 1)))))
           (else
             "  } else { \\\n"
             "      printf(\"Unsupported number of args from GC %d\\n\", gc_num_ans); \\\n"
                    "  } \n")))))
  (string-append
    "#define AFTER_LONGJMP \\\n"
    (append-next-clause 0))))

(define (c-macro-return-funcall num-args)<commit_msg>Removed obsolete macro generation<commit_after>;;
;; Cyclone Scheme
;; Copyright (c) 2014, <NAME>
;; All rights reserved.
;;
;; This module compiles scheme code to a Cheney-on-the-MTA C runtime.
;;

(define (emit line)
  (display line)
  (newline))

(define (emits str)
  (display str))

(define (emit-newline)
  (newline))

(define (string-join lst delim)
  (cond
    ((null? lst) 
      "")
    ((= (length lst) 1) 
      (car lst))
    (else
      (string-append 
        (car lst) 
        delim 
        (string-join (cdr lst) delim)))))

;; Escape chars in a C-string, so it can be safely written to a C file
(define (cstr:escape-chars str)
  (letrec ((next (lambda (head tail)
                   (cond
                     ((null? head) (list->string (reverse tail)))
                     ((equal? (car head) #\")
                      (next (cdr head) (cons #\" (cons #\\ tail))))
                     ((equal? (car head) #\\)
                      (next (cdr head) (cons #\\ (cons #\\ tail))))
                     ((equal? (car head) #\newline)
                      (next (cdr head) 
                            (cons #\n (cons #\\ tail))))
                     (else
                       (next (cdr head) (cons (car head) tail)))))))
    (next (string->list str) '())))

;; Name-mangling.

;; We have to "mangle" Scheme identifiers into
;; C-compatible identifiers, because names like
;; foo-bar/baz are not identifiers in C.

; mangle : symbol -> string
(define (mangle symbol)
 (letrec
   ((m (lambda (chars)
      (if (null? chars)
        '()
        (if (or (and (char-alphabetic? (car chars)) (not (char=? (car chars) #\_)))
                (char-numeric? (car chars)))
            (cons (car chars) (m (cdr chars)))
            (cons #\_ (append (integer->char-list (char->natural (car chars)))
                              (m (cdr chars))))))))
    (ident (list->string (m (string->list (symbol->string symbol))))))
   (if (member (string->symbol ident) *c-keywords*)
     (string-append "_" ident)
     ident)))

(define (mangle-global symbol)
  (string-append "__glo_" (mangle symbol)))

(define *c-keywords* 
 '(auto _Bool break case char _Complex const continue default do double else
   enum extern float for goto if _Imaginary inline int long register restrict
   return short signed sizeof static struct switch typedef union unsigned
   void volatile while
   list  ;; Not a keyword but reserved type
   ))

(define *c-main-function*
"main(int argc,char **argv)
{long stack_size = long_arg(argc,argv,\"-s\",STACK_SIZE);
 long heap_size = long_arg(argc,argv,\"-h\",HEAP_SIZE);
 global_stack_size = stack_size;
 global_heap_size = heap_size;
 main_main(stack_size,heap_size,(char *) &stack_size);
 return 0;}")

;;; Auto-generation of C macros
(define *c-call-arity* 5)

(define (set-c-call-arity! arity)
  (cond
    ((not (number? arity))
     (error `(Non-numeric number of arguments received ,arity)))
    (else
      (if (> arity *c-call-arity*)
          (set! *c-call-arity* arity)))))

(define (emit-c-macros)
  (c-macro-declare-globals)
  (c-macro-GC-globals)
  (emit-c-arity-macros 0))

(define (emit-c-arity-macros arity)
  (when (<= arity *c-call-arity*)
    (emit (c-macro-funcall arity))
    (emit (c-macro-return-funcall arity))
    (emit (c-macro-return-check arity))
    (emit-c-arity-macros (+ arity 1))))

(define (c-macro-return-funcall num-args)
{'fraction_non_alphanumeric': 0.1620837537840565, 'fraction_numerical': 0.0034056508577194754, 'mean_word_length': 2.148927720413026, 'pattern_counts': {'":': 0, '<': 8, '<?xml version=': 0, '>': 29, 'https://': 0, 'lorem ipsum': 0, 'www.': 0, 'xml': 0}, 'pii_count': 0, 'substrings_counts': 0, 'word_list_counts': {'cursed_substrings.json': 2, 'profanity_word_list.json': 0, 'sexual_word_list.json': 0, 'zh_pornsignals.json': 0}}
{'dir': 'git-commits-cleaned', 'id': '6896907', 'n_tokens_mistral': 2712, 'n_tokens_neox': 2574, 'n_words': 731}