Untitled

(define (iter1 s len res)
  (if (null? s)
      #t
      (if (and (>= (char->integer (car s)) 48) (<= (char->integer (car s)) 57))
          (iter1 (cdr s) (- len 1) (+ res (* (- (char->integer (car s)) 48) (expt 16 (- len 1)))))
          (if (or (equal? (car s) '#\a) (equal? (car s) '#\A))
              (iter1 (cdr s) (- len 1) (+ res (* 10 (expt 16 (- len 1)))))
              (if (or (equal? (car s) '#\b) (equal? (car s) '#\B))
                  (iter1 (cdr s) (- len 1) (+ res (* 11 (expt 16 (- len 1)))))
                  (if (or (equal? (car s) '#\c) (equal? (car s) '#\C))
                      (iter1 (cdr s) (- len 1) (+ res (* 12 (expt 16 (- len 1)))))
                      (if (or (equal? (car s) '#\d) (equal? (car s) '#\D))
                          (iter1 (cdr s) (- len 1) (+ res (* 13 (expt 16 (- len 1)))))
                          (if (or (equal? (car s) '#\e) (equal? (car s) '#\E))
                              (iter1 (cdr s) (- len 1) (+ res (* 14 (expt 16 (- len 1)))))
                              (if (or (equal? (car s) '#\f) (equal? (car s) '#\F))
                                  (iter1 (cdr s) (- len 1) (+ res (* 15 (expt 16 (- len 1)))))
                                  #f)))))))))

(define (iter2 s len res)
  (if (null? s)
      res
      (if (and (>= (char->integer (car s)) 48) (<= (char->integer (car s)) 57))
          (iter2 (cdr s) (- len 1) (+ res (* (- (char->integer (car s)) 48) (expt 16 (- len 1)))))
          (if (or (equal? (car s) '#\a) (equal? (car s) '#\A))
              (iter2 (cdr s) (- len 1) (+ res (* 10 (expt 16 (- len 1)))))
              (if (or (equal? (car s) '#\b) (equal? (car s) '#\B))
                  (iter2 (cdr s) (- len 1) (+ res (* 11 (expt 16 (- len 1)))))
                  (if (or (equal? (car s) '#\c) (equal? (car s) '#\C))
                      (iter2 (cdr s) (- len 1) (+ res (* 12 (expt 16 (- len 1)))))
                      (if (or (equal? (car s) '#\d) (equal? (car s) '#\D))
                          (iter2 (cdr s) (- len 1) (+ res (* 13 (expt 16 (- len 1)))))
                          (if (or (equal? (car s) '#\e) (equal? (car s) '#\E))
                              (iter2 (cdr s) (- len 1) (+ res (* 14 (expt 16 (- len 1)))))
                              (if (or (equal? (car s) '#\f) (equal? (car s) '#\F))
                                  (iter2 (cdr s) (- len 1) (+ res (* 15 (expt 16 (- len 1)))))
                                  #f)))))))))

(define (search s cur)
  (if (null? s)
      -1
      (if (or (equal? (car s) #\tab) (equal? (car s) #\newline) (equal? (car s) #\space))
          cur
          (search (cdr s) (+ cur 1)))))

(define (super-car s x res)
  (if (> x 0)
      (super-car (cdr s) (- x 1) (cons (car s) res))
      (reverse res)))

(define (super-cdr s x)
  (if (> x 0)
      (super-cdr (cdr s) (- x 1))
      s))

(define (iter3 s res)
  (if (null? s)
      (reverse res)
      (if (or (equal? (car s) #\tab) (equal? (car s) #\newline) (equal? (car s) #\space))
          (iter3 (cdr s) res)
          (begin
            (if (not (equal? -1 (search s 0)))
                (let* ((x (search s 0))
                       (cur (super-car s x '())))
                  (if (check-hex (list->string cur))
                      (iter3 (super-cdr s x) (cons (scan-hex (list->string cur)) res))
                      #f))
                (if (check-hex (list->string s))
                    (iter3 '() (cons (scan-hex (list->string s)) res))
                    #f))))))

;<Body> ::= <Specs> <Digits> <Symbols> .
;<Specs> ::= <Specs> <\t> < > <\n> | .
;<Digits> ::= <Digit> <Digits> | .
;<Digit> ::= <0> | <1> | <2> | <3> | <4> | <5> | <6> | <7> | <8> | <9> .
;<Symbols> ::= <Symbols> <Symbol> | .
;<Symbol> ::= <a> | <b> | <c> | <d> | <e> | <f> | <A> | <B> | <C> | <D> | <E> | <F> | .

(define (check-hex x)
  (let ((s (string->list x)))
    (if (and (>= (length s) 3) (equal? (car s) '#\0) (or (equal? (cadr s) '#\x) (equal? (cadr s) '#\X)))
        (iter1 (cddr s) (- (length s) 2) 0)
        #f)))

(define (scan-hex x)
  (if (check-hex x)
      (iter2 (cddr (string->list x)) (- (length (string->list x)) 2) 0)
      #f))

(define (scan-many-hexs x)
  (let ((res '())
        (s (string->list x)))
    (iter3 s res)))

(define (super-cons s x res)
  (if (and (null? s) (null? x))
      res
      (if (null? x)
          (super-cons (cdr s) x (cons (car s) res))
          (super-cons s (cdr x) (cons (car x) res)))))

(define (body program wc res ifs)
  (if ifs
      (if (equal? 'endif (vector-ref program wc))
          (list (+ wc 1) (list 'if (reverse res)))
          (if (equal? 'if (vector-ref program wc))
              (let ((cur (body program (+ wc 1) '() (+ wc 1))))
                (body program (car cur) (cons (cadr cur) res) (car cur)))
              (body program (+ wc 1) (cons (vector-ref program wc) res) ifs)))
      (if (>= wc (vector-length program))
          (list wc (reverse res))
          (if (equal? 'if (vector-ref program wc))
              (let ((cur (body program (+ wc 1) '() (+ wc 1))))
                (body program (car cur) (cons (cadr cur) res) #f))
              (body program (+ wc 1) (cons (vector-ref program wc) res) ifs)))))

(define (article program dic wc)
  (if (= wc (vector-length program))
      (list #f #f)
      (let ((cur (vector-ref program wc)))
        (if (equal? 'end cur)
            (list (+ wc 1) (cadr (body (list->vector (reverse dic)) 0 '() #f)))
            (article program (cons cur dic) (+ wc 1))))))

(define (articles program wc res)
  (let ((cur (vector-ref program wc)))
    (if (equal? cur 'define)
        (let ((x (article program '() (+ wc 2))))
          (begin
            (if (car x)
                (articles program (car x) (cons (list (vector-ref program (+ wc 1)) (cadr x)) res))
                (list #f #f))))
        (list wc (reverse res)))))

(define (parse program)
  (let* ((artres (articles program 0 '()))
         (art (cadr artres))
         (wc (car artres)))
    (if wc
        (list art (cadr (body program wc '() #f)))
        #f)))